source: project/chicken/trunk/scripts/chicken-bundle.scm @ 12053

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

Some procedures renamed to have meaningful names.

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