source: project/chicken/branches/chicken-3/scripts/chicken-bundle.scm @ 12096

Last change on this file since 12096 was 12096, checked in by Ivan Raikov, 12 years ago

Adding latest updates to release-3 branch.

File size: 9.3 KB
Line 
1;;
2;; Make a bundle of compiled C files for a given egg and all its
3;; dependencies.
4;;
5;; Usage: chicken-bundle [--build-dir=DIR] [--repo-dir=DIR] --chicken-dir=DIR <egg name> ...
6;;
7
8(require-extension srfi-1)
9(require-extension srfi-13)
10(require-extension posix)
11(require-extension regex)
12(require-extension utils)
13(require-extension args)
14
15(include "tools.scm")
16
17(define (lookup-def k lst . rest)
18  (let-optionals rest ((default #f))
19      (let ((kv (assoc k lst)))
20        (if (not kv) default
21            (match kv ((k v) v) (else (cdr kv)))))))
22
23(define chicken-include-dir (foreign-value "C_INSTALL_INCLUDE_HOME" c-string) )
24
25(define (s+ . lst)    (apply string-append (map ->string lst)))
26
27(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
28
29
30(define *default-cc-options* "-Os -fomit-frame-pointer -g -DHAVE_GRP_H")
31
32(define opts
33  `(
34    ,(args:make-option (build-dir)       (required: "DIR")   
35                       (s+ "build eggs in directory DIR"))
36    ,(args:make-option (cc-options)       (required: "STRING")   
37                       (s+ "C compiler options to be used in the makefile (default is " *default-cc-options* ")"))
38    ,(args:make-option (chicken-dir)       (required: "DIR")   
39                       (s+ "directory where Chicken C files can be found"))
40    ,(args:make-option (chicken-units)       (required: "LIST")   
41                       (s+ "Chicken units to be included with the bundle (comma-separated list)"))
42    ,(args:make-option (exclude)       (required: "LIST")   
43                       (s+ "libraries to be excluded from bundling (comma-separated list)"))
44    ,(args:make-option (repo-dir)       (required: "DIR")   
45                       (s+ "install eggs in directory DIR"))
46    ,(args:make-option (search-dirs)       (required: "DIR")   
47                       (s+ "comma-separated directory list where to search for library .scm files"))
48    ,(args:make-option (suffix)       (required: "STRING")   
49                       (s+ "use given suffix for archive name and top-level directory (default is -bundle)"))
50    ,(args:make-option (verbose)       #:none
51                       (s+ "enable verbose mode")
52                       (set! *verbose* #t))
53    ,(args:make-option (h help)  #:none               "Print help"
54                       (usage))
55
56    ))
57
58
59;; Use args:usage to generate a formatted list of options (from OPTS),
60;; suitable for embedding into help text.
61(define (usage)
62  (print "Usage: " (car (argv)) " options... [list of eggs to be bundled] ")
63  (newline)
64  (print "The following options are recognized: ")
65  (newline)
66  (print (parameterize ((args:indent 5)) (args:usage opts)))
67  (exit 1))
68
69
70;; Process arguments and collate options and arguments into OPTIONS
71;; alist, and operands (filenames) into OPERANDS.  You can handle
72;; options as they are processed, or afterwards.
73(define args    (command-line-arguments))
74(set!-values (options operands)  (args:parse args opts))
75
76(define dirsep (string ##sys#pathname-directory-separator))
77
78(define (read-subdirs path)
79  (find-files path directory? cons (list) 0))
80
81(define (read-c-files path)
82  (find-files path ".*.c" cons (list) 0))
83(define (read-h-files path)
84  (find-files path ".*.h" cons (list) 0))
85
86(define tmpdir-prefix
87  (make-parameter
88   (or (getenv "CHICKEN_TMPDIR") (getenv "TMPDIR")
89       (getenv "TMP") (getenv "TEMP")
90       ((lambda (user) 
91          (and user  (file-write-access? "/tmp") 
92               (conc "/tmp/chicken-bundle-" user))) 
93        (getenv "USER"))
94       ((lambda (home user) 
95          (and home user  (conc home "/tmp/chicken-bundle-" user))) 
96        (getenv "HOME") (getenv "USER"))
97       (current-directory))))
98
99
100(define (compute-unique-path dot-prefix)
101  (let loop ((num (random 10000)))
102    (let ((name  (string-append dot-prefix "." (number->string num)))
103          (path  (make-pathname (tmpdir-prefix) name)))
104      (if (file-exists? path) (loop (random 10000)) path))))
105
106(define (make-paths-c+h flst)
107  (concatenate (map (lambda (p) (append (map (lambda (f) (s+ (third p) dirsep f)) (fourth p))
108                                        (map (lambda (f) (s+ (third p) dirsep f)) (fifth p))))
109                    flst)))
110
111(define (make-paths-c flst)
112  (concatenate (map (lambda (p) (map (lambda (f) (s+ (third p) dirsep f)) (fifth p))) flst)))
113
114(define (build-makefile egg-name flst units cc-options)
115  (let ((units-c-files (map (lambda (u) (s+ u ".c")) units))
116        (libs-c-files  (make-paths-c flst)))
117  (message "Creating Makefile" )
118  (call-with-output-file "Makefile"
119    (lambda (out)
120      (let ((text #<#EOF
121## This file was generated by chicken-bundle
122##
123#(s+ egg-name ": ") runtime.c library.c #(sl\ " " units-c-files) #(sl\ " " libs-c-files)
124#(list->string (list #\tab)) $(CC) #(identity cc-options) -o $@ $^
125EOF
126))
127        (display text out))))))
128
129(define (build-bundle egg-name suffix repo-dir build-dir chicken-dir search-dirs
130                      chicken-units cc-options exclude)
131  (let ((cwd (current-directory))
132        (bundle-dir   (s+ build-dir dirsep egg-name suffix))
133        (bundle-name  (s+ egg-name suffix ".tar.gz") ))
134    (run (rm -rf ,(s+ build-dir dirsep "*")))
135    (run (rm -rf ,(s+ repo-dir  dirsep "*")))
136    (run (chicken-setup ,(if *verbose* "-v" "") -d -k -build-prefix ,build-dir -repository ,repo-dir ,egg-name))
137    (let ((flst
138           (let loop ((subdirs (read-subdirs build-dir))  (flst (list)))
139             (if (null? subdirs) flst
140                 (let* ((subdir (car subdirs))
141                        (c-files (read-c-files subdir))
142                        (h-files (read-h-files subdir))
143                        (subdir-name (pathname-strip-directory subdir))
144                        (subdir-eggname (third (string-split subdir-name ".")))
145                        (bundle-subdir-name (s+ subdir-eggname ".dir"))
146                        (c-file-names (map pathname-strip-directory c-files))
147                        (h-file-names (map pathname-strip-directory h-files)))
148                   (if (member subdir-eggname exclude)
149                       (loop (cdr subdirs) flst)
150                       (loop (cdr subdirs) (cons (list subdir-eggname 
151                                                       subdir-name bundle-subdir-name h-file-names
152                                                       c-file-names) flst))))))))
153      (if (null? flst) (error 'build-bundle "no C files found"))
154      (if (not (file-exists? bundle-dir))
155          (begin
156            (message "Creating directory ~a" bundle-dir)
157            (create-directory bundle-dir)))
158      (run (rm -rf ,(s+ bundle-dir dirsep "*")))
159      (change-directory bundle-dir)
160      (build-makefile egg-name flst chicken-units cc-options)
161      (run (cp ,(s+ chicken-include-dir dirsep "chicken.h") ,bundle-dir))
162      (run (cp ,(s+ chicken-dir dirsep "runtime.c") ,bundle-dir))
163      (run (cp ,(s+ chicken-dir dirsep "library.c") ,bundle-dir))
164      (for-each (lambda (u) (run (cp ,(s+ chicken-dir dirsep u ".c") ,bundle-dir))) chicken-units)
165      (change-directory build-dir)
166      (let ((lib-units 
167             (concatenate 
168              (map (lambda (p) 
169                     (let* ((this-egg (first p))
170                            (subdir   (second p))
171                            (cfns     (fifth p))
172                            (sfns     (map (lambda (x) (pathname-replace-extension x ".scm")) cfns)))
173                       (fold (lambda (fn ax) 
174                               (let* ((ep   (s+ subdir dirsep fn))
175                                      (epc  (pathname-replace-extension ep ".c"))
176                                      (ops  (map (lambda (d) (s+ subdir dirsep d dirsep fn)) search-dirs))
177                                      (u    (pathname-strip-extension fn))
178                                      (p    (find file-exists? (cons ep ops))))
179                                 (if p
180                                     (begin (run (csc ,@(if (not (string=? u "syntax-case"))
181                                                            `(-R syntax-case) `()) 
182                                                      -I ,subdir -unit ,u -e -t ,p -o ,epc))
183                                            (if (string=? u egg-name) ax 
184                                                (cons u ax)) )
185                                     ax)))
186                             (list) sfns)))
187                   flst))))
188        (let* ((egg-entry  (lookup-def egg-name flst))
189               (subdir     (first egg-entry))
190               (p          (s+ subdir dirsep egg-name ".scm")))
191          (run (csc -I ,subdir ,@(map (lambda (u) `(-uses ,u)) lib-units) -t ,p)))
192        (for-each (lambda (p) (run (mv ,(second p) ,(s+ bundle-dir dirsep (third p))))) flst)
193        (let* ((bundle-dir-name    (pathname-strip-directory bundle-dir))
194               (make-bundle-path   (lambda (x) (s+ bundle-dir-name dirsep x)))
195               (make-bundle-path+c (lambda (x) (s+ bundle-dir-name dirsep x ".c"))))
196          (run (tar zcf ,bundle-name 
197                    ,@(map make-bundle-path `(Makefile chicken.h runtime.c library.c ))
198                    ,@(map make-bundle-path  (make-paths-c+h flst)) 
199                    ,@(map make-bundle-path+c chicken-units))))
200        (run (mv ,(s+ build-dir dirsep bundle-name) ,cwd))
201        (change-directory cwd)
202        ))))
203               
204
205
206(define (main options operands)
207  (let ((opt_exclude       (or ((lambda (x) (and x (string-split x ","))) (alist-ref 'exclude options))
208                               (list)))
209        (opt_suffix        (or (alist-ref 'suffix options) "-bundle"))
210        (opt_cc-options    (or (alist-ref 'cc-options options) *default-cc-options*))
211        (opt_chicken-dir   (or (alist-ref 'chicken-dir options) "."))
212        (opt_search-dirs   (or ((lambda (x) (and x (string-split x ","))) (alist-ref 'search-dirs options))
213                               (list)))
214        (opt_chicken-units (or ((lambda (x) (and x (string-split x ","))) (alist-ref 'chicken-units options))
215                               (list "eval" "data-structures" "ports" "extras" "srfi-69")))
216        (opt_build-dir   (or (alist-ref 'build-dir options) (compute-unique-path "build")))
217        (opt_repo-dir    (or (alist-ref 'repo-dir options)  (compute-unique-path "repo"))))
218    (message "Build directory: ~a" opt_build-dir)
219    (message "Repository directory: ~a" opt_repo-dir)
220    ;; make sure build dir exists
221    (if (not (file-exists? opt_build-dir))
222        (begin
223          (message "Creating directory ~a" opt_build-dir)
224          (create-directory opt_build-dir)))
225    (if (not (file-exists? opt_repo-dir))
226        (begin
227          (message "Creating directory ~a" opt_repo-dir)
228          (create-directory opt_repo-dir)))
229    (for-each (lambda (x) (build-bundle x opt_suffix opt_repo-dir opt_build-dir opt_chicken-dir opt_search-dirs
230                                        opt_chicken-units opt_cc-options opt_exclude ))
231              operands)))
232
233(main options operands)
Note: See TracBrowser for help on using the repository browser.