source: project/release/4/setup-helper/trunk/setup-helper.scm @ 34411

Last change on this file since 34411 was 34411, checked in by Kon Lovett, 3 years ago

comment

File size: 14.6 KB
Line 
1;;;; setup-helper.scm -*- Hen -*-
2;;;; Kon Lovett, Mar '09
3
4;;Issues
5;;
6;; - Accepts anything as a pathname component (see '->string' use).
7;;
8;; - Static support is wrong. Must collect .o into .a !
9
10;;; Release 4 Only!
11
12(use
13  srfi-1
14  posix
15  extras
16  data-structures
17  files
18  setup-api)
19
20(define *has-emit-inline* #f)
21(define *has-emit-types* #f)
22(when (version>=? (chicken-version) "4.0.0")
23  (set! *has-emit-inline* #t) )
24(when (version>=? (chicken-version) "4.7.3")
25  (set! *has-emit-types* #t) )
26
27;;; Extension Information
28
29(define (verify-extension-name nam)
30  (let ((extnam (->string nam)))
31    (unless (string=? extnam (extension-name))
32      (error "unexpected extension-name" extnam (extension-name)) ) ) )
33
34;;; Support
35
36;; Simple type error report
37
38(define (sh:error-type loc obj #!optional typmsg)
39  (let* ((msg "bad argument type")
40         (msg (if typmsg (string-append msg " - not a " typmsg))) )
41    (##sys#signal-hook #:type-error loc msg obj) ) )
42
43;; Filename Support
44
45(define CHICKEN-SOURCE-EXTENSION "scm")
46(define CHICKEN-IMPORT-EXTENSION "import")
47(define CHICKEN-INLINE-EXTENSION "inline")
48(define CHICKEN-TYPES-EXTENSION "types")
49(define HTML-EXTENSION "html")
50(define STATIC-ARCHIVE-EXTENSION "a")
51(define OBJECT-BINARY-EXTENSION "o")
52(cond-expand
53  (windows
54    (define EXECUTABLE-EXTENSION "exe")
55    (define DIRECTORY-SEPARATOR "\\") )
56  (else
57    (define EXECUTABLE-EXTENSION #f)
58    (define DIRECTORY-SEPARATOR "/") ) )
59
60(define (installation-chicken-home)
61  (if (not (installation-prefix)) (chicken-home)
62    (make-pathname `(,(installation-prefix) "share") "chicken") ) )
63
64; from repo-path in setup-helper.scm
65(define (installation-repository-path)
66  (if (deployment-mode)
67    (installation-prefix) ; deploy: copy directly into destdir
68    (let ((p (destination-prefix)))
69      (if p
70        ; installation-prefix changed: use it
71        (make-pathname p (sprintf "lib/chicken/~a" (##sys#fudge 42)))
72        ; otherwise use repo-path
73        (repository-path) ) ) ) )
74
75(define (directory-separator? obj)
76  (string=? (->string obj) DIRECTORY-SEPARATOR) )
77
78(define (filename bn #!optional en)
79  (make-pathname #f (->string bn) (and en (->string en))) )
80
81(define (make-directory-name dir)
82  (let ((dir (if (symbol? dir) (symbol->string dir) dir)))
83    (cond
84      ((string? dir)
85        (let ((end (sub1 (string-length dir))))
86          (if (not (directory-separator? (string-ref dir end))) dir
87              (substring dir 0 end) ) ) )
88      ((pair? dir)
89        (let ((len (length dir)))
90          (if (= 1 len) (->string (car dir))
91              ;Ensures no trailing directory separator.
92              (make-pathname
93                (map ->string (take dir (sub1 len)))
94                (->string (last dir))) ) ) )
95      (else
96        (sh:error-type 'make-directory-name dir) ) ) ) )
97
98(define (document-filename bn)
99  (filename bn HTML-EXTENSION) )
100
101(define (source-filename bn)
102  (filename bn CHICKEN-SOURCE-EXTENSION) )
103
104(define (shared-library-filename bn)
105  (filename bn ##sys#load-library-extension) )
106
107(define (shared-filename bn)
108  (filename bn ##sys#load-dynamic-extension) )
109
110(define (static-library-filename bn)
111  (filename bn STATIC-ARCHIVE-EXTENSION) )
112
113(define (static-filename bn)
114  (filename bn OBJECT-BINARY-EXTENSION) )
115
116(define (import-filename bn)
117  (filename bn CHICKEN-IMPORT-EXTENSION) )
118
119(define (source-import-filename bn)
120  (source-filename (import-filename bn)) )
121
122(define (shared-import-filename bn)
123  (shared-filename (import-filename bn)) )
124
125(define (inline-filename bn)
126  (filename bn CHICKEN-INLINE-EXTENSION) )
127
128(define (types-filename bn)
129  (filename bn CHICKEN-TYPES-EXTENSION) )
130
131(define (program-filename bn)
132 (filename bn EXECUTABLE-EXTENSION) )
133
134(define (make-home-pathname bn)
135  (make-pathname (installation-chicken-home) bn) )
136
137(define (make-repository-pathname bn)
138  (make-pathname (installation-repository-path) bn) )
139
140;; File Support
141
142;This subverts the "installation-prefix" relative insurance.
143;(and uses the builtin to-path creation "feature").
144
145(define (copy-file-relative fn dn)
146  (copy-file `(,fn ,fn) dn #t dn) )
147
148;Keeps the "installation-prefix" relative insurance.
149;(and uses the builtin to-path creation "feature").
150
151(define (copy-file-absolute fn dn)
152  (copy-file `(,fn ,fn) dn) )
153
154(define (copy-file-to-directory fn dn)
155  (copy-file-relative fn dn) )
156
157(define (copy-to-installation-repository fn)
158  (copy-file-relative fn (installation-repository-path)) )
159
160(define (copy-to-repository fn)
161  (copy-to-installation-repository fn) )
162
163(define (copy-to-home fn)
164  (copy-file-relative fn (installation-chicken-home)) )
165
166(define (built-filename nam knd)
167  (cond
168    ((symbol? knd)
169      (case knd
170        ((static) (static-filename nam))
171        ((shared) (shared-filename nam))
172        ((inline) (inline-filename nam))
173        ((types) (types-filename nam))
174        ((import) (shared-import-filename nam))
175        ((document) (document-filename nam))
176        (else
177          (sh:error-type 'built-filename knd "symbolic kind" ) ) ) )
178    ((procedure? knd)
179      (knd nam) )
180    (else
181      (sh:error-type 'built-filename knd "symbol or procedure") ) ) )
182
183(define (built-file nam . knds)
184  (let loop ((knds (if (and (null? (cdr knds)) (list? (car knds))) (car knds) knds))
185            (ls '()))
186    (if (null? knds) (reverse ls)
187      (let ((gnflnm (built-filename nam (car knds))))
188        (loop (cdr knds)
189              (if (file-exists? gnflnm) (cons gnflnm ls) ls))) ) ) )
190
191;; File Mode Support
192
193; mod is a symbol, ex: 'a+r
194(define (file-chmod pn mod)
195  (cond-expand
196    (windows)
197    (else
198      (run (,(if (sudo-install) "sudo chmod" "chmod") ,mod ,(shellpath pn))) ) ) )
199
200;; Single File Install Support
201
202(define (install-in-repository fn)
203  (when (setup-install-mode)
204    (copy-to-repository fn) ) )
205
206(define (install-in-home fn)
207  (when (setup-install-mode)
208    (copy-to-home fn) ) )
209
210;; SRFI-29 Bundle Support
211
212(define (srfi-29-bundles-home)
213  (make-repository-pathname "srfi-29-bundles") )
214
215(define (make-srfi-29-bundle-directory-name spec)
216  (if (null? spec)
217    (srfi-29-bundles-home)
218    (make-directory-name (append (list (srfi-29-bundles-home)) spec)) ) )
219
220(define (ensure-srfi-29-bundle-directory-mod spec #!optional (mod 'a+rx))
221  (let loop ((dn (srfi-29-bundles-home)) (spec spec))
222    (unless (null? spec)
223      (let ((dn (make-directory-name (append (list dn) (list (car spec))))))
224        (file-chmod dn mod)
225        (loop dn (cdr spec)) ) ) ) )
226
227(define (install-srfi-29-bundle nam . spec)
228  (when (setup-install-mode)
229    (unless (directory? (srfi-29-bundles-home))
230      (error "missing SRFI-29 bundles directory; please install SRFI-29") )
231    (let* ((nam (->string nam))
232           (spec (map ->string spec))
233           (dir (make-srfi-29-bundle-directory-name spec)) )
234            ;Explicit curdir ('.') because problems in the past.
235      (let ((from (make-pathname (append '(".") spec) nam))
236            (to (make-pathname dir nam)) )
237        (copy-file from to #t dir)
238        (file-chmod to 'a+r) )
239      (ensure-srfi-29-bundle-directory-mod spec) ) ) )
240
241;; Compile Support
242
243;FIXME -...o style!
244(define (output-file-option compile-options)
245  (or (memq '-o compile-options)
246      (memq '-output-file compile-options)) )
247
248(define (optional-output-file compile-options)
249  (let ((of (output-file-option compile-options)))
250    (if of (list (cadr of)) '()) ) )
251
252;;; Compile
253
254;; Default Options
255
256#;
257(define include-path-options
258  (make-parameter
259    (cond-expand
260      (macosx    '(-I/opt/local/include -I/sw/include))
261      (else      '()))))
262
263#;
264(define library-path-options
265  (make-parameter
266    (cond-expand
267      (macosx    '(-L/opt/local/lib -L/sw/lib))
268      (else      '()))))
269
270;Bad idea to make `-local' the default for a module compile (but not an import
271;compile) since it means something like `fluid-let' cannot be used on an
272;exported binding.
273
274;The import filename base must be the module name!
275;The inline filename base must be the output name!
276;So assume unused when explicit output name.
277
278(define default-static-compile-options
279  (make-parameter '(
280    -c
281    -optimize-leaf-routines -inline)))
282
283(define default-shared-compile-options
284  (make-parameter '(
285    -shared
286    -optimize-leaf-routines -inline)))
287
288(define default-import-compile-options
289  (make-parameter '(
290    -shared
291    -optimize-leaf-routines -inline
292    -local
293    -no-trace -no-lambda-info)))
294
295;; Compile Action
296
297(define (has-emit-inline inline? nam)
298  (if (not (and *has-emit-inline* inline?)) '()
299    `(-emit-inline-file ,(inline-filename nam)) ) )
300
301(define (has-emit-types types? nam)
302  (if (not (and *has-emit-types* types?)) '()
303    `(-emit-type-file ,(types-filename nam)) ) )
304
305;compile expands using back-quote
306
307(define (compile-static nam #!key (options '()) inline? types?)
308  (compile
309    ,(source-filename nam)
310    ,@(default-static-compile-options)
311    -unit ,nam
312    ,@(if (output-file-option options) '() `(-output-file ,(static-filename nam)))
313    ,@(has-emit-inline inline? nam)
314    ,@(has-emit-types types? nam)
315    ,@options) )
316
317(define (compile-shared nam #!key (options '()) inline? types?)
318  (compile
319    ,(source-filename nam)
320    ,@(default-shared-compile-options)
321    ,@(if (output-file-option options) '() `(-output-file ,(shared-filename nam)))
322    ,@(has-emit-inline inline? nam)
323    ,@(has-emit-types types? nam)
324    ,@options) )
325
326(define (compile-static-module nam #!key (options '()) inline? types?)
327  (compile
328    ,(source-filename nam)
329    ,@(default-static-compile-options)
330    -unit ,nam
331    ,@(if (output-file-option options) '() `(-output-file ,(static-filename nam)))
332    -emit-import-library ,nam
333    ,@(has-emit-inline inline? nam)
334    ,@(has-emit-types types? nam)
335    ,@options)
336  (compile
337    ,(source-import-filename nam)
338    ,@(default-import-compile-options)
339    -output-file ,(shared-import-filename nam)) )
340
341(define (compile-shared-module nam #!key (options '()) inline? types?)
342  (compile
343    ,(source-filename nam)
344    ,@(default-shared-compile-options)
345    ,@(if (output-file-option options) '() `(-output-file ,(shared-filename nam)))
346    -emit-import-library ,nam
347    ,@(has-emit-inline inline? nam)
348    ,@(has-emit-types types? nam)
349    ,@options)
350  (compile
351    ,(source-import-filename nam)
352    ,@(default-import-compile-options)
353    -output-file ,(shared-import-filename nam)) )
354
355;;; Install
356
357(define default-static-install-options
358  (make-parameter '()))
359
360(define default-shared-install-options
361  (make-parameter '()))
362
363(define default-static-module-install-options
364  (make-parameter '()))
365
366(define default-shared-module-install-options
367  (make-parameter '()))
368
369(define default-shared+static-module-install-options
370  (make-parameter '()))
371
372;;
373
374(define (install-static-extension nam ver #!key (options '()) (files '()) output-file?)
375  (install-extension nam
376   `(,@(built-file nam 'static 'inline 'types)
377     ,@files)
378   `(,@(default-static-install-options)
379     (version ,ver)
380     ;FIXME what about explicit output file
381     (static ,(static-filename nam))
382     (documentation ,(document-filename nam))
383     ,@options)) )
384
385(define (install-shared-extension nam ver #!key (options '()) (files '()) output-file?)
386  (install-extension nam
387   `(,@(built-file nam 'shared 'inline 'types)
388     ,@files)
389   `(,@(default-shared-install-options)
390     (version ,ver)
391     (documentation ,(document-filename nam))
392     ,@options)) )
393
394(define (install-static-extension-module nam ver #!key (options '()) (files '()) output-file?)
395  (install-extension nam
396   `(,@(built-file nam 'static 'import 'inline 'types)
397     ,@files)
398   `(,@(default-static-module-install-options)
399     (version ,ver)
400     ;FIXME what about explicit output file & .a
401     (static ,(static-filename nam))
402     (documentation ,(document-filename nam))
403     ,@options)) )
404
405(define (install-shared-extension-module nam ver #!key (options '()) (files '()) output-file?)
406  (install-extension nam
407   `(,@(built-file nam 'shared 'import 'inline 'types)
408     ,@files)
409   `(,@(default-shared-module-install-options)
410     (version ,ver)
411     (documentation ,(document-filename nam))
412     ,@options)) )
413
414(define (install-shared+static-extension-module nam ver
415          #!key (options '()) (files '()) shared-output-file? static-output-file?)
416  (install-extension nam
417   `(,@(built-file nam 'shared 'import 'static 'inline 'types)
418     ,@files)
419   `(,@(default-shared+static-module-install-options)
420     (version ,ver)
421     ;FIXME what about explicit output file & .a
422     (static ,(static-filename nam))
423     (documentation ,(document-filename nam))
424     ,@options)) )
425
426;;; Setup
427
428(define (setup-static-extension nam ver
429          #!key (compile-options '())
430                inline? types?
431                (install-options '()) (files '()))
432  (let ((files (append files (optional-output-file compile-options))))
433    (compile-static nam #:options compile-options #:inline? inline? #:types? types?)
434    (install-static-extension nam ver #:options install-options #:files files) ) )
435
436(define (setup-shared-extension nam ver
437          #!key (compile-options '())
438                inline? types?
439                (install-options '()) (files '()))
440  (let ((files (append files (optional-output-file compile-options))))
441    (compile-shared nam #:options compile-options #:inline? inline? #:types? types?)
442    (install-shared-extension nam ver #:options install-options #:files files) ) )
443
444(define (setup-static-extension-module nam ver
445          #!key (compile-options '())
446                inline? types?
447                (install-options '()) (files '()))
448  (let ((files (append files (optional-output-file compile-options))))
449    (compile-static-module nam #:options compile-options #:inline? inline? #:types? types?)
450    (install-static-extension-module nam ver #:options install-options #:files files) ) )
451
452(define (setup-shared-extension-module nam ver
453          #!key (compile-options '())
454                inline? types?
455                (install-options '()) (files '()))
456  (let ((files (append files (optional-output-file compile-options))))
457    (compile-shared-module nam #:options compile-options #:inline? inline? #:types? types?)
458    (install-shared-extension-module nam ver #:options install-options #:files files) ) )
459
460;cannot support -output-file option
461(define (setup-shared+static-extension-module nam ver
462          #!key (shared-compile-options '())
463                (static-compile-options '())
464                (compile-options '())
465                inline? types?
466                (install-options '()) (files '()))
467  (compile-shared-module nam
468    #:options (append compile-options shared-compile-options)
469    #:inline? inline? #:types? types?)
470  (compile-static nam #:options (append compile-options static-compile-options))
471  (install-shared+static-extension-module nam ver #:options install-options #:files files) )
472
473;; Empty "Conglomerate" Extension Support
474
475(define (install-extension-tag nam ver) (install-extension nam '() `((version ,ver))))
Note: See TracBrowser for help on using the repository browser.