~ chicken-core (chicken-5) 9f7aeaeb7b78f4bd4797bec36c2767028b5b7eb0
commit 9f7aeaeb7b78f4bd4797bec36c2767028b5b7eb0
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: Thu Aug 18 17:51:37 2016 +0200
various corrections and enhancements in egg-compile/new-install
diff --git a/NOTES b/NOTES
index 7dd2763d..03d73efb 100644
--- a/NOTES
+++ b/NOTES
@@ -2,11 +2,18 @@ NOTES (new install)
===============
+* TODO Extract feathers patches and submit to -hackers
+
+* TODO Rebase on upstream at some stage
+
* Complete egg-info compilation
** TODO What should the default optimization options be?
- also for compiled import libraries.
- respect DEBUGBUILD?
+* TODO Support for generating + installing extra files
+ - types, inline-files
+
* Implement minimal "chicken-install"
** TODO rename new-install.scm later
- rules.make
@@ -23,6 +30,7 @@ NOTES (new install)
* TODO repository-path
- allow multiple locations?
- CHICKEN_REPOSITORY
+ currently "destination-repository" is used in mode cases.
- perhaps: CHICKEN_INSTALL_REPOSITORY (defaults to install-prefix) as
installation target.
@@ -33,13 +41,16 @@ NOTES (new install)
** Link-options are passed directly to csc
- is this right?
+* Dropped
+ - sudo mode
+
* Setup features
** TODO Keep binaries + intermediate files.
** TODO drop "keep-going" mode.
** TODO "-feature" + "-no-feature"
** TODO Hack for OSX SIP?
** TODO reinstall, no-install?
-** TODO Drop -setup-mode
+** TODO Request by Jon Foerch: allow *.egg in specific subdirectory ("chicken"?)
* TODO "build-dependencies"
- toplevel deps that are needed during build, override "dependencies", if given.
@@ -70,12 +81,11 @@ NOTES (new install)
* TODO Drop CHICKEN_PREFIX
* Build/install scripts
+** TODO Use "-setup-mode" when invoking csc during build?
** TODO fully sh(1) compatible
- http://people.fas.harvard.edu/~lib113/reference/unix/portable_scripting.html
- https://www.microsoft.com/resources/documentation/windows/xp/all/proddocs/en-us/cmd.mspx?mfr=true
-** TODO "chicken-do" tool to build if dependencies are newer than target
- - "usage: chicken-do TARGET CMD ... : DEPENDENCIES ..."
- - try to avoid quoting hell, especially on Windows.
+** TODO Test "chicken-do" and port to Windows
- ideally, use execvp/CreateProcess
- http://www.cplusplus.com/forum/windows/3398/ and
http://www.cplusplus.com/forum/beginner/1988/3/#msg14102
@@ -86,20 +96,38 @@ NOTES (new install)
- can we ignore this? if source files have different names, just compiling exe/so directly should
work.
+* TODO Do we have to cleanup after building eggs?
+
* Install scripts
** TODO Allow overrriding DESTDIR, PREFIX
** TODO Install setup-info
** TODO Use install(1) ?
+* TODO Integrate running tests into build-script
+
* Tools
** TODO chicken-install
** TODO chicken-uninstall
** TODO chicken-status
* TODO Copyright headers
+ - chicken-do.c egg-*.scm
* TODO Documentation
- remove old and obsolete stuff (deployment, dropped options, etc.)
- update manual
- chicken-do
- update egg-tutorial on wiki
+
+cm chicken-do
+cm chicken-install chicken-config.h
+git gui
+gg CHICKEN_BUG_PROGRAM
+
+~/chicken/5 rules.make
+~/share/chicken/feathers.tcl
+~/chicken/4/srfi-113
+
+chicken-install.scm setup-api.scm
+new-install.scm egg-compile.scm egg-environment.scm
+gg setup-info
\ No newline at end of file
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