source: project/url/setup-header.scm @ 4212

Last change on this file since 4212 was 4212, checked in by Kon Lovett, 13 years ago

New setup-header w/ source install support.

File size: 9.0 KB
Line 
1;;;; setup-header.scm
2;;;; Kon Lovett, May '06
3
4(required-chicken-version 2.5)
5
6;;; Constants & Procedures
7
8(define REPOSITORY-DIRECTORY (repository-path))
9
10;; These must be kept in synch w/ testbase-results.scm!
11
12(define TESTBASE-DIRECTORY (make-pathname REPOSITORY-DIRECTORY "testbase"))
13(define TESTBASE-TESTS-DIRECTORY (make-pathname TESTBASE-DIRECTORY "tests"))
14
15(define (->symbol obj)
16  (cond
17    [(symbol? obj)  obj]
18    [(string? obj)  (string->symbol obj)]
19    [else           (string->symbol (->string obj))]) )
20
21;; Pathname Constructors
22
23(define (make-filename bn . en)
24  (apply make-pathname #f (->string bn) en) )
25
26(define (make-docu-filename bn)
27  (make-filename bn "html") )
28
29(define (make-dynld-filename bn)
30  (make-filename bn ##sys#load-dynamic-extension) )
31
32(define (make-source-filename bn)
33  (make-filename bn "scm") )
34
35(define (make-exports-filename bn)
36  (make-filename bn "exports") )
37
38(define (make-program-filename bn)
39  (make-filename bn (and (eq? 'windows (software-type)) ".exe")) )
40
41(define (make-repository-pathname bn)
42  (make-pathname REPOSITORY-DIRECTORY bn) )
43
44(define (make-program-pathname dn pn)
45  (make-pathname dn (make-program-filename pn)) )
46
47;;
48
49(define (installed-program-exists? bn)
50  (or (file-exists? (make-program-pathname (program-path) bn))
51      (file-exists? (make-program-pathname (installation-prefix) bn))) )
52
53;; File Copy Operations
54
55(define (*file-copy fn dn)
56  (let ([fn (->string fn)])
57    (copy-file fn (make-pathname dn fn)) ) )
58
59(define (copy-to-repository fn)
60  (*file-copy (->string fn) REPOSITORY-DIRECTORY) )
61
62(define (copy-to-shared fn)
63  (*file-copy (->string fn) (chicken-home)) )
64
65(define (copy-file-to-test-repository fn)
66  (*file-copy (->string fn) TESTBASE-TESTS-DIRECTORY) )
67
68;; Install & Run Test(s)
69
70(define-constant TESTBASE-TEST-DRIVER "chicken-testbase-driver")
71(define-constant TESTBASE-TEST-DRIVER-OPTIONS "--indent 2")
72
73(define test-driver-arguments
74  (make-parameter
75    (string-append TESTBASE-TEST-DRIVER-OPTIONS (if (setup-verbose-flag) " -v" ""))
76    (lambda (x) (if (string? x) x (test-driver-arguments)))))
77
78(define (install-test . flnms)
79  (newline)
80  (print "* Installing test files in " TESTBASE-TESTS-DIRECTORY #\:)
81  (unless (file-exists? TESTBASE-TESTS-DIRECTORY)
82    (create-directory TESTBASE-TESTS-DIRECTORY) )
83  (let ([tsts
84          (map
85            (lambda (x)
86              (if (list? x)
87                ;then has extra files (probably test data)
88                (begin
89                  (for-each (cut copy-file-to-test-repository <>) x)
90                  (car x))
91                ;else test is self contained
92                (begin
93                  (copy-file-to-test-repository x)
94                  x)))
95            flnms)])
96  (if (string>? "2.610" (chicken-version))
97    (begin
98      (newline)
99      (print "* Chicken 2.610+ needed to perform testing.") )
100    (if (installed-program-exists? TESTBASE-TEST-DRIVER)
101      (begin
102        (when (setup-verbose-flag)
103          (newline)
104          (print "* Running test files" #\:) )
105        ; Quote driver command for Windows.
106        ; Test filenames CANNOT include whitespace.
107        (for-each
108          (cute system* "\"~A\" ~A ~A" TESTBASE-TEST-DRIVER (test-driver-arguments) <>)
109          tsts) )
110      (begin
111        (newline)
112        (print "* TestBase is not installed. Cannot perform testing.") ) ) ) ) )
113
114;; Options Parsing
115
116(define (parse-install-arguments ver opt)
117  ;
118  (set! ver
119    (cond
120      [(string? ver)  ver]
121      [(symbol? ver)  (eval ver)]
122      [(number? ver)  (number->string ver)]
123      [else           (error "invalid install version argument" ver)]))
124  ;
125  (let ([cmp-args '()] [rqr@run '()] [opt-args '()])
126    (let loop ([lst opt])
127      (if (null? lst)
128        (values ver (reverse cmp-args) rqr@run opt-args)
129        (let ([itm (car lst)])
130          (cond
131            [(pair? itm)
132              (if (eq? 'require-at-runtime (car itm))
133                (set! rqr@run (append (cdr itm) rqr@run))
134                (set! opt-args (cons itm opt-args)) )]
135            [(symbol? itm)
136              (let ([str (symbol->string itm)])
137                (if (char=? #\+ (string-ref str 0))
138                  (set! cmp-args
139                    (append
140                      `(,(string->symbol (substring str 1)) -extend)
141                      cmp-args))
142                  (set! cmp-args (cons itm cmp-args)) ) )]
143            [(atom? itm)
144              (set! cmp-args (cons itm cmp-args))]
145            [else
146              (set! opt-args (cons itm opt-args))])
147          (loop (cdr lst)) )) ) ) )
148
149;;; Operation Macros
150
151;; Note that these can accept quasi- stuff in OPT
152
153(define-macro (compile-dynld DYNFIL . OPT)
154  `(compile
155    -s
156    -O2 -d1
157    ,(make-source-filename DYNFIL)
158    -o ,(make-dynld-filename DYNFIL)
159    -check-imports -emit-exports ,(make-exports-filename DYNFIL)
160    ,@OPT) )
161
162(define-macro (compile-dynld/rename SRCDYNFIL OUTDYNFIL . OPT)
163  `(compile
164    -s
165    -O2 -d1
166    ,(make-source-filename SRCDYNFIL)
167    -o ,(make-dynld-filename OUTDYNFIL)
168    -check-imports -emit-exports ,(make-exports-filename OUTDYNFIL)
169    ,@OPT) )
170
171;; Note that these cannot accept quasi-stuff in OPT
172
173(define-macro (install-dynld DYNFIL VER . OPT)
174  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
175    `(begin
176      (compile-dynld ,DYNFIL ,@CMP-ARGS)
177      (install-extension ',(->symbol DYNFIL)
178        '(,(make-dynld-filename DYNFIL) )
179        '(,@OPT-ARGS
180          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
181          (version ,VERSTR)
182          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
183
184(define-macro (install-dynld+docu DYNFIL VER . OPT)
185  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
186    `(begin
187      (compile-dynld ,DYNFIL ,@CMP-ARGS)
188      (install-extension ',(->symbol DYNFIL)
189        '(,(make-dynld-filename DYNFIL)
190          ,(make-docu-filename DYNFIL) )
191        '(,@OPT-ARGS
192          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
193          (documentation ,(make-docu-filename DYNFIL))
194          (version ,VERSTR)
195          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
196
197(define-macro (install-dynld+source DYNFIL VER . OPT)
198  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
199    `(begin
200      (compile-dynld ,DYNFIL ,@CMP-ARGS)
201      (install-extension ',(->symbol DYNFIL)
202        '(,(make-dynld-filename DYNFIL)
203          ,(make-source-filename DYNFIL) )
204        '(,@OPT-ARGS
205          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
206          (version ,VERSTR)
207          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
208
209(define-macro (install-dynld+source+docu DYNFIL VER . OPT)
210  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
211    `(begin
212      (compile-dynld ,DYNFIL ,@CMP-ARGS)
213      (install-extension ',(->symbol DYNFIL)
214        '(,(make-dynld-filename DYNFIL)
215          ,(make-source-filename DYNFIL)
216          ,(make-docu-filename DYNFIL) )
217        '(,@OPT-ARGS
218          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
219          (documentation ,(make-docu-filename DYNFIL))
220          (version ,VERSTR)
221          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
222
223(define-macro (install-syntax SYNFIL VER . OPT)
224  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
225    `(install-extension ',(->symbol SYNFIL)
226      '(,(make-source-filename SYNFIL) )
227      '(,@OPT-ARGS
228        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
229        (version ,VERSTR)
230        (syntax) ) ) ) )
231
232(define-macro (install-syntax+docu SYNFIL VER . OPT)
233  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
234    `(install-extension ',(->symbol SYNFIL)
235      '(,(make-source-filename SYNFIL)
236        ,(make-docu-filename SYNFIL) )
237      '(,@OPT-ARGS
238        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
239        (version ,VERSTR)
240        (documentation ,(make-docu-filename SYNFIL))
241        (syntax) ) ) ) )
242
243(define-macro (install-dynld+syntax SYNFIL DYNFIL VER . OPT)
244  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
245    `(begin
246      (compile-dynld ,DYNFIL ,@CMP-ARGS)
247      (install-extension ',(->symbol SYNFIL)
248        '(,(make-source-filename SYNFIL)
249          ,(make-dynld-filename DYNFIL) )
250        '(,@OPT-ARGS
251          (syntax)
252          (require-at-runtime ,(->symbol DYNFIL) ,@RQR@RUN)
253          (version ,VERSTR)
254          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
255
256(define-macro (install-dynld+syntax+docu SYNFIL DYNFIL VER . OPT)
257  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
258    `(begin
259      (compile-dynld ,DYNFIL ,@CMP-ARGS)
260      (install-extension ',(->symbol SYNFIL)
261        '(,(make-docu-filename SYNFIL)
262          ,(make-source-filename SYNFIL)
263          ,(make-dynld-filename DYNFIL) )
264        '(,@OPT-ARGS
265          (documentation ,(make-docu-filename SYNFIL))
266          (syntax)
267          (require-at-runtime ,(->symbol DYNFIL) ,@RQR@RUN)
268          (version ,VERSTR)
269          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.