source: project/synch/setup-header.scm @ 4418

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

New setup-header.

File size: 9.5 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-static-filename bn)
33  (make-filename bn "o") )
34
35(define (make-source-filename bn)
36  (make-filename bn "scm") )
37
38(define (make-exports-filename bn)
39  (make-filename bn "exports") )
40
41(define (make-program-filename bn)
42  (make-filename bn (and (eq? 'windows (software-type)) ".exe")) )
43
44(define (make-repository-pathname bn)
45  (make-pathname REPOSITORY-DIRECTORY bn) )
46
47(define (make-program-pathname dn pn)
48  (make-pathname dn (make-program-filename pn)) )
49
50;;
51
52(define (installed-program-exists? bn)
53  (or (file-exists? (make-program-pathname (program-path) bn))
54      (file-exists? (make-program-pathname (installation-prefix) bn))) )
55
56;; File Copy Operations
57
58(define (*file-copy fn dn)
59  (let ([fn (->string fn)])
60    (copy-file fn (make-pathname dn fn)) ) )
61
62(define (copy-to-repository fn)
63  (*file-copy (->string fn) REPOSITORY-DIRECTORY) )
64
65(define (copy-to-shared fn)
66  (*file-copy (->string fn) (chicken-home)) )
67
68(define (copy-file-to-test-repository fn)
69  (*file-copy (->string fn) TESTBASE-TESTS-DIRECTORY) )
70
71;; Install & Run Test(s)
72
73(define-constant TESTBASE-TEST-DRIVER "chicken-testbase-driver")
74(define-constant TESTBASE-TEST-DRIVER-OPTIONS "--indent 2")
75
76(define test-driver-arguments
77  (make-parameter
78    (string-append TESTBASE-TEST-DRIVER-OPTIONS
79                   (if (setup-verbose-flag) " -v" ""))
80    (lambda (x)
81      (if (string? x) x (test-driver-arguments)))))
82
83(define (copy-tests . flnms)
84  (unless (file-exists? TESTBASE-TESTS-DIRECTORY)
85    (create-directory TESTBASE-TESTS-DIRECTORY) )
86  (map
87    (lambda (x)
88      (if (list? x)
89        ; then has extra files (probably test data)
90        (begin
91          (for-each (cut copy-file-to-test-repository <>) x)
92          (car x))
93        ; else test is self contained
94        (begin (copy-file-to-test-repository x) x)))
95    flnms) )
96
97(define (run-tests . tsts)
98  ; Quote driver command for Windows.
99  ; Test filenames CANNOT include whitespace (Windows issue).
100  (for-each
101    (cute system* "\"~A\" ~A ~A"
102                  TESTBASE-TEST-DRIVER (test-driver-arguments) <>)
103    tsts) )
104
105(define (install-test . flnms)
106  (newline)
107  (print "* Installing TestBase Test-Files in " TESTBASE-TESTS-DIRECTORY #\:)
108  (let ([tsts (apply copy-tests flnms)])
109    (if (installed-program-exists? TESTBASE-TEST-DRIVER)
110      (begin
111        (when (setup-verbose-flag)
112          (newline)
113          (print "* Running test files" #\:) )
114        (apply run-tests tsts) )
115      (begin
116        (newline)
117        (print "* TestBase Driver is not installed; cannot perform testing.") ) ) ) )
118
119;; Options Parsing
120
121(define (parse-install-arguments ver opt)
122  ;
123  (set! ver
124    (cond
125      [(string? ver)  ver]
126      [(symbol? ver)  (eval ver)]
127      [(number? ver)  (number->string ver)]
128      [else           (error "invalid install version argument" ver)]))
129  ;
130  (let ([cmp-args '()] [rqr@run '()] [opt-args '()])
131    (let loop ([lst opt])
132      (if (null? lst)
133        (values ver (reverse cmp-args) rqr@run opt-args)
134        (let ([itm (car lst)])
135          (cond
136            [(pair? itm)
137              (if (eq? 'require-at-runtime (car itm))
138                (set! rqr@run (append (cdr itm) rqr@run))
139                (set! opt-args (cons itm opt-args)) )]
140            [(symbol? itm)
141              (let ([str (symbol->string itm)])
142                (if (char=? #\+ (string-ref str 0))
143                  (set! cmp-args
144                    (append
145                      `(,(string->symbol (substring str 1)) -extend)
146                      cmp-args))
147                  (set! cmp-args (cons itm cmp-args)) ) )]
148            [(atom? itm)
149              (set! cmp-args (cons itm cmp-args))]
150            [else
151              (set! opt-args (cons itm opt-args))])
152          (loop (cdr lst)) )) ) ) )
153
154;;; Operation Macros
155
156;; Note that these can accept quasi- stuff in OPT
157
158(define-macro (compile-dynld DYNFIL . OPT)
159  `(compile
160    -s
161    -O2 -d1
162    ,(make-source-filename DYNFIL)
163    -o ,(make-dynld-filename DYNFIL)
164    -check-imports -emit-exports ,(make-exports-filename DYNFIL)
165    ,@OPT) )
166
167(define-macro (compile-dynld/rename SRCDYNFIL OUTDYNFIL . OPT)
168  `(compile
169    -s
170    -O2 -d1
171    ,(make-source-filename SRCDYNFIL)
172    -o ,(make-dynld-filename OUTDYNFIL)
173    -check-imports -emit-exports ,(make-exports-filename OUTDYNFIL)
174    ,@OPT) )
175
176(define-macro (compile-static SRCSTAFIL . OPT)
177  `(compile
178    -c
179    -O2 -d1
180    ,(make-source-filename SRCSTAFIL)
181    -unit ,SRCSTAFIL
182    -o ,(make-static-filename SRCSTAFIL)
183    -check-imports -emit-exports ,(make-exports-filename SRCSTAFIL)
184    ,@OPT) )
185
186(define-macro (compile-static/rename SRCSTAFIL OUTSTAFIL . OPT)
187  `(compile
188    -c
189    -O2 -d1
190    ,(make-source-filename SRCSTAFIL)
191    -unit ,OUTSTAFIL
192    -o ,(make-static-filename OUTSTAFIL)
193    -check-imports -emit-exports ,(make-exports-filename OUTSTAFIL)
194    ,@OPT) )
195
196;; Note that these cannot accept quasi-stuff in OPT
197
198(define-macro (install-dynld DYNFIL VER . OPT)
199  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
200    `(begin
201      (compile-dynld ,DYNFIL ,@CMP-ARGS)
202      (install-extension ',(->symbol DYNFIL)
203        '(,(make-dynld-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+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-docu-filename DYNFIL) )
216        '(,@OPT-ARGS
217          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
218          (documentation ,(make-docu-filename DYNFIL))
219          (version ,VERSTR)
220          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
221
222(define-macro (install-dynld+source DYNFIL VER . OPT)
223  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
224    `(begin
225      (compile-dynld ,DYNFIL ,@CMP-ARGS)
226      (install-extension ',(->symbol DYNFIL)
227        '(,(make-dynld-filename DYNFIL)
228          ,(make-source-filename DYNFIL) )
229        '(,@OPT-ARGS
230          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
231          (version ,VERSTR)
232          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
233
234(define-macro (install-dynld+source+docu DYNFIL VER . OPT)
235  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
236    `(begin
237      (compile-dynld ,DYNFIL ,@CMP-ARGS)
238      (install-extension ',(->symbol DYNFIL)
239        '(,(make-dynld-filename DYNFIL)
240          ,(make-source-filename DYNFIL)
241          ,(make-docu-filename DYNFIL) )
242        '(,@OPT-ARGS
243          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
244          (documentation ,(make-docu-filename DYNFIL))
245          (version ,VERSTR)
246          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
247
248(define-macro (install-syntax SYNFIL VER . OPT)
249  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
250    `(install-extension ',(->symbol SYNFIL)
251      '(,(make-source-filename SYNFIL) )
252      '(,@OPT-ARGS
253        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
254        (version ,VERSTR)
255        (syntax) ) ) ) )
256
257(define-macro (install-syntax+docu SYNFIL VER . OPT)
258  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
259    `(install-extension ',(->symbol SYNFIL)
260      '(,(make-source-filename SYNFIL)
261        ,(make-docu-filename SYNFIL) )
262      '(,@OPT-ARGS
263        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
264        (version ,VERSTR)
265        (documentation ,(make-docu-filename SYNFIL))
266        (syntax) ) ) ) )
267
268(define-macro (install-dynld+syntax SYNFIL DYNFIL VER . OPT)
269  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
270    `(begin
271      (compile-dynld ,DYNFIL ,@CMP-ARGS)
272      (install-extension ',(->symbol SYNFIL)
273        '(,(make-source-filename SYNFIL)
274          ,(make-dynld-filename DYNFIL) )
275        '(,@OPT-ARGS
276          (syntax)
277          (require-at-runtime ,(->symbol DYNFIL) ,@RQR@RUN)
278          (version ,VERSTR)
279          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
280
281(define-macro (install-dynld+syntax+docu SYNFIL DYNFIL VER . OPT)
282  (let-values (([VERSTR CMP-ARGS RQR@RUN OPT-ARGS] (parse-install-arguments VER OPT)))
283    `(begin
284      (compile-dynld ,DYNFIL ,@CMP-ARGS)
285      (install-extension ',(->symbol SYNFIL)
286        '(,(make-docu-filename SYNFIL)
287          ,(make-source-filename SYNFIL)
288          ,(make-dynld-filename DYNFIL) )
289        '(,@OPT-ARGS
290          (documentation ,(make-docu-filename SYNFIL))
291          (syntax)
292          (require-at-runtime ,(->symbol DYNFIL) ,@RQR@RUN)
293          (version ,VERSTR)
294          (exports ,(make-exports-filename DYNFIL)) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.