Changeset 12096 in project

Timestamp:

10/02/08 01:53:55 (12 years ago)

Author:

Ivan Raikov

Message:

Adding latest updates to release-3 branch.

File:

• chicken/branches/chicken-3/scripts/chicken-bundle.scm (modified) (8 diffs)

chicken/branches/chicken-3/scripts/chicken-bundle.scm

@@ -14 +14 @@
 
 (include "tools.scm")
+
+(define (lookup-def k lst . rest)
+  (let-optionals rest ((default #f))
+      (let ((kv (assoc k lst)))
+        (if (not kv) default
+            (match kv ((k v) v) (else (cdr kv)))))))
 
 (define chicken-include-dir (foreign-value "C_INSTALL_INCLUDE_HOME" c-string) )
@@ -38 +44 @@
     ,(args:make-option (repo-dir)       (required: "DIR")    
                        (s+ "install eggs in directory DIR"))
+    ,(args:make-option (search-dirs)       (required: "DIR")    
+                       (s+ "comma-separated directory list where to search for library .scm files"))
     ,(args:make-option (suffix)       (required: "STRING")    
                        (s+ "use given suffix for archive name and top-level directory (default is -bundle)"))
@@ -97 +105 @@
 
 (define (make-paths-c+h flst)
-  (concatenate (map (lambda (p) (append (map (lambda (f) (s+ (second p) dirsep f)) (third p))
-                                        (map (lambda (f) (s+ (second p) dirsep f)) (fourth p))))
+  (concatenate (map (lambda (p) (append (map (lambda (f) (s+ (third p) dirsep f)) (fourth p))
+                                        (map (lambda (f) (s+ (third p) dirsep f)) (fifth p))))
                     flst)))
 
 (define (make-paths-c flst)
-  (concatenate (map (lambda (p) (map (lambda (f) (s+ (second p) dirsep f)) (fourth p))) flst)))
+  (concatenate (map (lambda (p) (map (lambda (f) (s+ (third p) dirsep f)) (fifth p))) flst)))
 
 (define (build-makefile egg-name flst units cc-options)
@@ -119 +127 @@
         (display text out))))))
 
-(define (build-bundle egg-name suffix repo-dir build-dir chicken-dir 
+(define (build-bundle egg-name suffix repo-dir build-dir chicken-dir search-dirs
                       chicken-units cc-options exclude)
   (let ((cwd (current-directory))
@@ -140 +148 @@
                    (if (member subdir-eggname exclude)
                        (loop (cdr subdirs) flst)
-                       (loop (cdr subdirs) (cons (list subdir-name bundle-subdir-name h-file-names
+                       (loop (cdr subdirs) (cons (list subdir-eggname 
+                                                       subdir-name bundle-subdir-name h-file-names
                                                        c-file-names) flst))))))))
       (if (null? flst) (error 'build-bundle "no C files found"))
@@ -155 +164 @@
       (for-each (lambda (u) (run (cp ,(s+ chicken-dir dirsep u ".c") ,bundle-dir))) chicken-units)
       (change-directory build-dir)
-      (for-each (lambda (p) (run (mv ,(first p) ,(s+ bundle-dir dirsep (second p))))) flst)
-      (let* ((bundle-dir-name (pathname-strip-directory bundle-dir))
-             (make-bundle-path   (lambda (x) (s+ bundle-dir-name dirsep x)))
-             (make-bundle-path+c (lambda (x) (s+ bundle-dir-name dirsep x ".c"))))
-        (run (tar zcf ,bundle-name 
-                  ,@(map make-bundle-path `(Makefile chicken.h runtime.c library.c ))
-                  ,@(map make-bundle-path  (make-paths-c+h flst)) 
-                  ,@(map make-bundle-path+c chicken-units))))
-      (run (mv ,(s+ build-dir dirsep bundle-name) ,cwd))
-      (change-directory cwd)
-      )))
+      (let ((lib-units 
+             (concatenate 
+              (map (lambda (p) 
+                     (let* ((this-egg (first p))
+                            (subdir   (second p))
+                            (cfns     (fifth p))
+                            (sfns     (map (lambda (x) (pathname-replace-extension x ".scm")) cfns)))
+                       (fold (lambda (fn ax) 
+                               (let* ((ep   (s+ subdir dirsep fn))
+                                      (epc  (pathname-replace-extension ep ".c"))
+                                      (ops  (map (lambda (d) (s+ subdir dirsep d dirsep fn)) search-dirs))
+                                      (u    (pathname-strip-extension fn))
+                                      (p    (find file-exists? (cons ep ops))))
+                                 (if p
+                                     (begin (run (csc ,@(if (not (string=? u "syntax-case"))
+                                                            `(-R syntax-case) `()) 
+                                                      -I ,subdir -unit ,u -e -t ,p -o ,epc))
+                                            (if (string=? u egg-name) ax 
+                                                (cons u ax)) )
+                                     ax)))
+                             (list) sfns)))
+                   flst))))
+        (let* ((egg-entry  (lookup-def egg-name flst))
+               (subdir     (first egg-entry))
+               (p          (s+ subdir dirsep egg-name ".scm")))
+          (run (csc -I ,subdir ,@(map (lambda (u) `(-uses ,u)) lib-units) -t ,p)))
+        (for-each (lambda (p) (run (mv ,(second p) ,(s+ bundle-dir dirsep (third p))))) flst)
+        (let* ((bundle-dir-name    (pathname-strip-directory bundle-dir))
+               (make-bundle-path   (lambda (x) (s+ bundle-dir-name dirsep x)))
+               (make-bundle-path+c (lambda (x) (s+ bundle-dir-name dirsep x ".c"))))
+          (run (tar zcf ,bundle-name 
+                    ,@(map make-bundle-path `(Makefile chicken.h runtime.c library.c ))
+                    ,@(map make-bundle-path  (make-paths-c+h flst)) 
+                    ,@(map make-bundle-path+c chicken-units))))
+        (run (mv ,(s+ build-dir dirsep bundle-name) ,cwd))
+        (change-directory cwd)
+        ))))
                 
 
@@ -175 +210 @@
         (opt_cc-options    (or (alist-ref 'cc-options options) *default-cc-options*))
         (opt_chicken-dir   (or (alist-ref 'chicken-dir options) "."))
+        (opt_search-dirs   (or ((lambda (x) (and x (string-split x ","))) (alist-ref 'search-dirs options))
+                               (list)))
         (opt_chicken-units (or ((lambda (x) (and x (string-split x ","))) (alist-ref 'chicken-units options))
-                               (list "data-structures" "utils" "extras" "srfi-1" "srfi-4" "srfi-13" "srfi-14")))
+                               (list "eval" "data-structures" "ports" "extras" "srfi-69")))
         (opt_build-dir   (or (alist-ref 'build-dir options) (compute-unique-path "build")))
         (opt_repo-dir    (or (alist-ref 'repo-dir options)  (compute-unique-path "repo"))))
@@ -190 +227 @@
           (message "Creating directory ~a" opt_repo-dir)
           (create-directory opt_repo-dir)))
-    (for-each (lambda (x) (build-bundle x opt_suffix opt_repo-dir opt_build-dir opt_chicken-dir 
+    (for-each (lambda (x) (build-bundle x opt_suffix opt_repo-dir opt_build-dir opt_chicken-dir opt_search-dirs
                                         opt_chicken-units opt_cc-options opt_exclude ))
               operands)))