~ chicken-core (chicken-5) 34d36e0c22748d8efb6fe012e68b59d09fd280a9
commit 34d36e0c22748d8efb6fe012e68b59d09fd280a9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 18 17:51:37 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Nov 13 11:32:20 2016 +0100
various corrections and enhancements in egg-compile/new-install
diff --git a/egg-compile.scm b/egg-compile.scm
index d6bc8831..a5018901 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -5,10 +5,11 @@
'(synopsis authors category license version dependencies files
source-file csc-options test-dependencies destination linkage
build-dependencies components foreign-dependencies link-options
- custom-bulild target host platform))
+ custom-bulild target host platform doc-from-wiki extension program
+ data))
(define nested-items
- '(components target host))
+ '(components target host extension program data))
(define named-items
'(extension program data c-include scheme-include))
@@ -21,10 +22,11 @@
(define default-dynamic-extension-link-options '())
(define default-extension-linkage '(static dynamic))
(define default-program-linkage '(dynamic))
-(define unix-executable-extension "")
-(define windows-executable-extension ".exe")
-(define unix-object-extension ".o")
-(define windows-object-extension ".obj")
+
+(define +unix-executable-extension+ "")
+(define +windows-executable-extension+ ".exe")
+(define +unix-object-extension+ ".o")
+(define +windows-object-extension+ ".obj")
;;; validate egg-information tree
@@ -34,15 +36,16 @@
(error "egg-information has invalid structure"))
(for-each
(lambda (item)
- (cond ((not (and (list? item) (pair? item) (symbol? (car item))))
- (error "egg-information item has invalid structure" item))
- ((not (memq (car item) valid-items))
- (error "invalid item" item))
- ((and (memq (car item) named-items) (not (symbol? (cadr item))))
- (error "missing name for item" item))
- ((memq (car item) nested-items)
- (validate-egg-info
- (if (memq (car item) named-items) (cddr item) (cdr item))))))
+ (unless (and (list? item) (pair? item) (symbol? (car item)))
+ (error "egg-information item has invalid structure" item))
+ (when (and (memq (car item) named-items) (not (symbol? (cadr item))))
+ (error "missing name for item" item))
+ (if (memq (car item) nested-items)
+ (validate-egg-info (if (memq (car item) named-items)
+ (cddr item)
+ (cdr item)))
+ (unless (memq (car item) valid-items)
+ (error "invalid item" item))))
info)
info)
@@ -69,19 +72,24 @@
(define (object-extension platform)
(case platform
- ((unix) unix-object-extension)
- ((windows) windows-object-extension)))
+ ((unix) +unix-object-extension+)
+ ((windows) +windows-object-extension+)))
(define (executable-extension platform)
(case platform
- ((unix) unix-executable-extension)
- ((windows) windows-executable-extension)))
+ ((unix) +unix-executable-extension+)
+ ((windows) +windows-executable-extension+)))
(define (copy-directory-command platform)
(case platform
((unix) "cp")
((windows) "xcopy /y")))
+(define (mkdir-command platform)
+ (case platform
+ ((unix) "mkdir -p")
+ ((windows) "mkdir")))
+
(define install-command copy-directory-command)
(define (destination-repository mode)
@@ -328,102 +336,122 @@
;;; shell code generation - build operations
(define (gen-compile-static-extension name #!key mode platform dependencies source
- options custom)
+ (options '()) custom)
(let ((cmd (or custom
(conc default-csc " -D compiling-extension -c -J -unit " name
" -D compiling-static-extension")))
(out (quotearg (target-file (conc name (object-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder platform) " " out " " cmd (arglist options)
- " " src " -o " out " : "
- src (arglist dependencies))))
+ (print (slashify default-builder platform) " " out " " cmd (arglist options)
+ " " src " -o " out " : "
+ src (arglist dependencies))))
(define (gen-compile-dynamic-extension name #!key mode platform dependencies mode
- source options link-options custom)
+ source (options '()) (link-options '())
+ custom)
(let ((cmd (or custom
(conc default-csc " -D compiling-extension -J -s")))
(out (quotearg (target-file (conc name ".so") mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder platform) " " out " " cmd (arglist options)
- (arglist link-options) " " src " -o " out " : "
- src (arglist dependencies))))
+ (print (slashify default-builder platform) " " out " " cmd (arglist options)
+ (arglist link-options) " " src " -o " out " : "
+ src (arglist dependencies))))
(define (gen-compile-import-library name #!key platform dependencies source mode
- options link-options custom)
+ (options '()) (link-options '())
+ custom)
(let ((cmd (or custom (conc default-csc " -s")))
(out (quotearg (target-file (conc name ".import.so") mode)))
(src (quotearg (or source (conc name ".import.scm")))))
- (conc (slashify default-builder platform) " " out " " cmd (arglist options)
- (arglist link-options) " " src " -o " out " : "
- src (arglist dependencies))))
+ (print (slashify default-builder platform) " " out " " cmd (arglist options)
+ (arglist link-options) " " src " -o " out " : "
+ src (arglist dependencies))))
(define (gen-compile-dynamic-program name #!key platform dependencies source mode
- options link-options custom)
+ (options '()) (link-options '())
+ custom)
(let ((cmd (or custom default-csc))
(out (quotearg
(target-file (conc name (executable-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder platform) " " out " " cmd (arglist options)
- (arglist link-options) " " src " -o " out " : "
- src (arglist dependencies))))
+ (print (slashify default-builder platform) " " out " " cmd (arglist options)
+ (arglist link-options) " " src " -o " out " : "
+ src (arglist dependencies))))
(define (gen-compile-static-program name #!key platform dependencies source
- options link-options custom mode)
+ (options '()) (link-options '())
+ custom mode)
(let ((cmd (or custom (conc default-csc " -static-libs")))
(out (quotearg
(target-file (conc name (executable-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder platform) " " out " " cmd (arglist options)
- (arglist link-options) " " src " -o " out " : "
- src (arglist dependencies))))
+ (print (slashify default-builder platform) " " out " " cmd (arglist options)
+ (arglist link-options) " " src " -o " out " : "
+ src (arglist dependencies))))
;; installation operations
(define (gen-install-static-extension name #!key platform mode)
(let* ((cmd (install-command platform))
+ (mkdir (mkdir-command platform))
(ext (object-extension platform))
(out (quotearg (target-file (conc name ext) mode)))
- (dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ext) platform)))))
+ (dest (destination-repository mode))
+ (dfile (quotearg dest platform)))
+ (print mkdir " " dfile)
+ (print cmd " " out " " (quotearg (slashify dest "/" name ext) platform))))
(define (gen-install-dynamic-extension name #!key platform mode)
- (let ((cmd (install-command platform))
- (out (quotearg (target-file (conc name ".so") mode)))
- (dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ".so") platform)))))
+ (let* ((cmd (install-command platform))
+ (out (quotearg (target-file (conc name ".so") mode)))
+ (ext (object-extension platform))
+ (dest (destination-repository mode))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd " " out " " (quotearg (slashify dest "/" name ".so") platform))))
(define (gen-install-import-library name #!key platform mode)
- (let ((cmd (install-command platform))
- (out (quotearg (target-file (conc name ".import.so") mode)))
- (dest (destination-repository mode)))
- (conc cmd " " out " "
- (quotearg (slashify (conc dest "/" name ".import.so") platform)))))
+ (let* ((cmd (install-command platform))
+ (out (quotearg (target-file (conc name ".import.so") mode)))
+ (dest (destination-repository mode))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd " " out " "
+ (quotearg (slashify (conc dest "/" name ".import.so") platform)))))
(define (gen-install-import-library-source name #!key platform mode)
- (let ((cmd (install-command platform))
- (out (quotearg (target-file (conc name ".import.scm") mode)))
- (dest (destination-repository mode)))
- (conc cmd " " out " "
+ (let* ((cmd (install-command platform))
+ (out (quotearg (target-file (conc name ".import.scm") mode)))
+ (dest (destination-repository mode))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd " " out " "
(quotearg (slashify (conc dest "/" name ".import.scm") platform)))))
(define (gen-install-program name #!key platform mode)
(let* ((cmd (install-command platform))
(ext (executable-extension platform))
(out (quotearg (target-file (conc name ext) mode)))
- (dest (if (eq? mode 'target) target-bindir host-bindir)))
- (conc cmd " " out " "
- (quotearg (slashify (conc dest "/" name ext) platform)))))
+ (dest (if (eq? mode 'target) target-bindir host-bindir))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd " " out " "
+ (quotearg (slashify (conc dest "/" name ext) platform)))))
(define (gen-install-data name #!key platform files destination mode)
(let* ((cmd (install-command platform))
- (dest (or destination (if (eq? mode 'target) target-sharedir host-sharedir))))
- (conc cmd (arglist files) " " (quotearg (slashify dest platform)))))
+ (dest (or destination (if (eq? mode 'target) target-sharedir host-sharedir)))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd (arglist files) " " dfile)))
(define (gen-install-c-include name #!key platform deps files dest mode)
(let* ((cmd (install-command platform))
- (dest (or dest (if (eq? mode 'target) target-incdir host-incdir))))
- (conc cmd " " (arglist files) " " (quotearg (slashify dest platform)))))
+ (dest (or dest (if (eq? mode 'target) target-incdir host-incdir)))
+ (dfile (quotearg (slashify dest platform))))
+ (print mkdir " " dfile)
+ (print cmd " " (arglist files) " " dfile)))
(define command-table
`((compile-static-extension ,gen-compile-static-extension)
@@ -446,17 +474,76 @@
(define (generate-shell-commands platform cmds dest prefix suffix)
(with-output-to-file dest
(lambda ()
- (prefix)
+ (prefix platform)
(for-each
(lambda (cmd)
+ (d "~s~%" cmd)
(cond ((assq (car cmd) command-table)
=> (lambda (op)
- (apply (cadr op) (cons* platform: platform (cddr cmd)))))
+ (apply (cadr op)
+ (cons* (cadr cmd) platform: platform (cddr cmd)))))
(else (error "invalid command" cmd))))
cmds)
- (suffix))))
+ (suffix platform))))
+;;; affixes for build- and install-scripts
+
+(define ((build-prefix mode name info) platform)
+ (case platform
+ ((unix)
+ (printf #<<EOF
+#!/bin/sh~%
+EOF
+ ))
+ ((windows)
+ (printf #<<EOF
+@echo off
+EOF
+ ))))
+
+(define ((build-suffix mode name info) platform)
+ (case platform
+ ((unix)
+ (printf #<<EOF
+EOF
+ ))
+ ((windows)
+ (printf #<<EOF
+EOF
+ ))))
+
+(define ((install-prefix mode name info) platform)
+ (case platform
+ ((unix)
+ (printf #<<EOF
+#!/bin/sh~%
+EOF
+ ))
+ ((windows)
+ (printf #<<EOF
+@echo off~%
+EOF
+ ))))
+
+(define ((install-suffix mode name info) platform)
+ (let ((infostr (with-output-to-string (cut pp info)))
+ (dest (make-pathname (destination-repository mode) name +egg-info-extension+)))
+ (case platform
+ ((unix)
+ (printf #<<EOF
+cat >~a <<ENDINFO
+~aENDINFO~%
+EOF
+ dest infostr))
+ ((windows)
+ (printf #<<EOF
+echo ~a >~a~%
+EOF
+ (string-intersperse (string-split infostr) "^\n")
+ dest)))))
+
+
;;; some utilities for mangling + quoting
(define (quotearg str)
diff --git a/new-install.scm b/new-install.scm
index 2430a6c5..a2e3dce2 100644
--- a/new-install.scm
+++ b/new-install.scm
@@ -11,6 +11,7 @@
(import (chicken format))
(import (chicken irregex))
(import (chicken tcp))
+(import (chicken ports))
(import (chicken posix))
(import (chicken io))
(import (chicken time))
@@ -43,6 +44,7 @@
(define proxy-port #f)
(define proxy-user-pass #f)
(define retrieve-only #f)
+(define do-not-build #f)
(define list-versions-only #f)
(define canonical-eggs '())
(define dependencies '())
@@ -79,7 +81,17 @@
'target
'host)))
-
+(define (build-script-extension mode platform)
+ (string-append "build"
+ (if (eq? mode 'target) ".target" "")
+ (if (eq? platform 'windows) ".bat" ".sh")))
+
+(define (install-script-extension mode platform)
+ (string-append "install"
+ (if (eq? mode 'target) ".target" "")
+ (if (eq? platform 'windows) ".bat" ".sh")))
+
+
;; usage information
(define (usage code)
@@ -267,7 +279,7 @@
(> (- now (with-input-from-file timestamp read)) +one-hour+)
(not (check-server-version name version lversion)))
(fetch)
- (let ((info (load-egg-info eggfile)))
+ (let ((info (load-egg-info eggfile))) ; new egg info (fetched)
(values cached (get-egg-property info 'version))))
(else (values cached version))))))
@@ -282,21 +294,23 @@
(define (fetch-egg-sources name version dest)
(let loop ((locs default-locations))
(cond ((null? locs)
- (let loop ((srvs default-servers))
- (receive (dir ver)
- (try-download name (resolve-location (car srvs))
- version: version
- destination: dest
- tests: run-tests
- proxy-host: proxy-host
- proxy-port: proxy-port
- proxy-user-pass: proxy-user-pass)
- (cond (dir
- (with-output-to-file
- (make-pathname dest +timestamp-file+)
- (lambda () (write (current-seconds)))))
- ((null? srvs) (error "extension or version not found"))
- (else (loop (cdr srvs)))))))
+ (let ((tmpdir (create-temporary-directory)))
+ (let loop ((srvs default-servers))
+ (receive (dir ver)
+ (try-download name (resolve-location (car srvs))
+ version: version
+ destination: tmpdir
+ tests: run-tests
+ proxy-host: proxy-host
+ proxy-port: proxy-port
+ proxy-user-pass: proxy-user-pass)
+ (cond (dir
+ (rename-file tmpdir dest)
+ (with-output-to-file
+ (make-pathname dest +timestamp-file+)
+ (lambda () (write (current-seconds)))))
+ ((null? srvs) (error "extension or version not found"))
+ (else (loop (cdr srvs))))))))
((probe-dir (make-pathname (car locs) name))
=> (lambda (dir)
(let* ((eggfile (make-pathname dir name +egg-extension+))
@@ -350,6 +364,7 @@
(for-each
(lambda (e+d+v)
(unless (member (car e+d+v) checked-eggs)
+ (d "checking ~a ...~%" (car e+d+v))
(set! checked-eggs (cons (car e+d+v) checked-eggs))
(let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))
(info (load-egg-info fname)))
@@ -379,7 +394,7 @@
#;(for-each
(lambda (e)
(d "removing previously installed extension `~a'" e)
- (remove-extension e) )
+ (remove-extension e) ) ; - not implemented yet
ueggs)
(retrieve-eggs ueggs) ) ) ) ) ) )
canonical-eggs)))
@@ -401,7 +416,7 @@
(define (get-egg-dependencies info)
(append (get-egg-property info 'dependencies '())
- (if run-tests (get-egg-property info 'test-dependencies '()))))
+ (if run-tests (get-egg-property info 'test-dependencies '()) '())))
(define (check-dependency dep)
(cond ((or (symbol? dep) (string? dep))
@@ -542,8 +557,69 @@
;; perform installation of retrieved eggs
(define (install-eggs)
- ;; ...
- #f)
+ (for-each
+ (lambda (egg)
+ (let* ((name (car egg))
+ (dir (cadr egg))
+ (eggfile (make-pathname dir name +egg-extension+))
+ (info (load-egg-info eggfile #f)))
+ (when (or host-extension
+ (and (not target-extension)
+ (not host-extension)))
+ (let-values (((build install info) (compile-egg-info info platform 'host)))
+ (let ((bscript (make-pathname dir name
+ (build-script-extension 'host platform)))
+ (iscript (make-pathname dir name
+ (install-script-extension 'host
+ platform))))
+ (generate-shell-commands platform build bscript
+ (build-prefix 'host name info)
+ (build-suffix 'host name info))
+ (generate-shell-commands platform install iscript
+ (install-prefix 'host name info)
+ (install-suffix 'host name info))
+ (run-script dir bscript platform)
+ (run-script dir iscript platform))))
+ (when target-extension
+ (let-values (((build install info) (compile-egg-info info platform 'target)))
+ (let ((bscript (make-pathname dir name
+ (build-script-extension 'target platform)))
+ (iscript (make-pathname dir name
+ (install-script-extension 'target
+ platform))))
+ (generate-shell-commands platform build bscript
+ (build-prefix 'target name info)
+ (build-suffix 'target name info))
+ (generate-shell-commands platform install iscript
+ (install-prefix 'target name info)
+ (install-suffix 'target name info))
+ (run-script dir bscript platform)
+ (run-script dir iscript platform))))))
+ canonical-eggs))
+
+(define (run-script dir script platform)
+ (if do-not-build
+ (print script)
+ (let ((old (current-directory)))
+ (change-directory dir)
+ (d "running script ~a~%" script)
+ (if (eq? platform 'windows)
+ (exec script)
+ (exec (string-append "sh " (make-pathname "." script))))
+ (change-directory old))))
+
+(define (write-info name info mode)
+ (d "writing info for egg ~a~%" name info)
+ (let ((infofile (make-pathname name (destination-repository mode))))
+ (when (eq? platform 'unix)
+ (exec (string-append "chmod a+r " (quotearg infofile))))))
+
+(define (exec cmd)
+ (d "executing: ~s~%" cmd)
+ (let ((r (system cmd)))
+ (unless (zero? r)
+ (error "shell command terminated with nonzero exit code" r cmd))))
+
;; command line parsing and selection of operations
@@ -554,6 +630,7 @@
(map (lambda (fname)
(list (pathname-file fname) (current-directory) #f))
(glob "*.egg")))
+ (retrieve-eggs '())
(install-eggs))
(else
(let ((eggs (apply-mappings eggs)))
@@ -594,6 +671,9 @@
((equal? arg "-target")
(set! host-extension #f)
(loop (cdr args)))
+ ((equal? arg "-n")
+ (set! do-not-build #t)
+ (loop (cdr args)))
;;XXX
Trap