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

Last change on this file since 34699 was 34699, checked in by Kon Lovett, 2 years ago

suppress global inline

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