~ chicken-core (master) /egg-compile.scm
Trap1;;;; egg-info processing and compilation
2;
3; Copyright (c) 2017-2022, The CHICKEN Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10; disclaimer.
11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12; disclaimer in the documentation and/or other materials provided with the distribution.
13; Neither the name of the author nor the names of its contributors may be used to endorse or promote
14; products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(define default-extension-options '())
28(define default-program-options '())
29(define default-static-program-link-options '())
30(define default-dynamic-program-link-options '())
31(define default-static-extension-link-options '())
32(define default-dynamic-extension-link-options '())
33(define default-static-compilation-options '("-O2" "-d1"))
34(define default-dynamic-compilation-options '("-O2" "-d1"))
35(define default-import-library-compilation-options '("-O2" "-d0"))
36
37(define default-program-linkage
38 (if staticbuild '(static) '(dynamic)))
39
40(define default-extension-linkage
41 (if staticbuild '(static) '(static dynamic)))
42
43(define +unix-executable-extension+ "")
44(define +windows-executable-extension+ ".exe")
45(define +unix-object-extension+ ".o")
46(define +unix-archive-extension+ ".a")
47(define +windows-object-extension+ ".obj")
48(define +windows-archive-extension+ ".a")
49(define +link-file-extension+ ".link")
50
51(define keep-generated-files #f)
52(define dependency-targets '())
53
54
55;;; some utilities
56
57(define override-prefix
58 (let ((prefix (get-environment-variable "CHICKEN_INSTALL_PREFIX")))
59 (lambda (dir default)
60 (if prefix
61 (string-append prefix dir)
62 default))))
63
64(define (object-extension platform)
65 (case platform
66 ((unix) +unix-object-extension+)
67 ((windows) +windows-object-extension+)))
68
69(define (archive-extension platform)
70 (case platform
71 ((unix) +unix-archive-extension+)
72 ((windows) +windows-archive-extension+)))
73
74(define (executable-extension platform)
75 (case platform
76 ((unix) +unix-executable-extension+)
77 ((windows) +windows-executable-extension+)))
78
79(define (copy-directory-command platform)
80 "cp -r")
81
82(define (copy-file-command platform)
83 "cp")
84
85(define (mkdir-command platform)
86 "mkdir -p")
87
88(define (install-executable-command platform)
89 (string-append default-install-program " "
90 default-install-program-executable-flags))
91
92(define (install-file-command platform)
93 (string-append default-install-program " "
94 default-install-program-data-flags))
95
96(define (remove-file-command platform)
97 "rm -f")
98
99(define (cd-command platform)
100 "cd")
101
102(define (uses-compiled-import-library? mode)
103 (not (and (eq? mode 'host) staticbuild)))
104
105;; this one overrides "destination-repository" in egg-environment to allow use of
106;; CHICKEN_INSTALL_PREFIX (via "override-prefix")
107(define (effective-destination-repository mode #!optional run)
108 (if (eq? 'target mode)
109 (if run target-run-repo target-repo)
110 (or (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")
111 (override-prefix (string-append "/lib/chicken/" (number->string binary-version))
112 host-repo))))
113
114;;; topological sort with cycle check
115
116(define (sort-dependencies dag eq)
117 (condition-case (topological-sort dag eq)
118 ((exn runtime cycle)
119 (error "cyclic dependencies" dag))))
120
121
122;;; collect import libraries for all modules
123
124(define (import-libraries mods dest rtarget mode)
125 (define (implib name)
126 (conc dest "/" name ".import."
127 (if (uses-compiled-import-library? mode)
128 "so"
129 "scm")))
130 (if mods
131 (map implib mods)
132 (list (implib rtarget))))
133
134
135;;; normalize target path for "random files" (data, c-include, scheme-include)
136
137(define (normalize-destination dest mode)
138 (let ((dest* (normalize-pathname dest)))
139 (if (irregex-search '(: bos ".." ("\\/")) dest*)
140 (error "destination must be relative to CHICKEN install prefix" dest)
141 (normalize-pathname
142 (make-pathname (if (eq? mode 'target)
143 default-prefix
144 (override-prefix "/" host-prefix))
145 dest*)))))
146
147
148;;; check condition in conditional clause
149
150(define (check-condition tst mode link)
151 (define (fail x)
152 (error "invalid conditional expression in `cond-expand' clause"
153 x))
154 (let walk ((x tst))
155 (cond ((and (list? x) (pair? x))
156 (cond ((and (eq? (car x) 'not) (= 2 (length x)))
157 (not (walk (cadr x))))
158 ((eq? 'and (car x)) (every walk (cdr x)))
159 ((eq? 'or (car x)) (any walk (cdr x)))
160 (else (fail x))))
161 ((memq x '(dynamic static)) (memq x link))
162 ((memq x '(target host)) (memq x mode))
163 ((symbol? x) (feature? x))
164 (else (fail x)))))
165
166
167;;; parse custom configuration information from script
168
169(define (parse-custom-config arg)
170 (define (read-all)
171 (let loop ((lst '()))
172 (let ((x (read)))
173 (if (eof-object? x)
174 (reverse lst)
175 (loop (append (reverse (flatten x)) lst))))))
176 (if (and (list? arg) (eq? 'custom-config (car arg)))
177 (let* ((arg (cdr arg))
178 (in (with-input-from-pipe
179 (conc default-csi " -s "
180 (if (list? arg)
181 (string-intersperse (map ->string arg) " ")
182 (->string arg)))
183 read-all)))
184 (map ->string in))
185 (list arg)))
186
187
188;;; compile an egg-information tree into abstract build/install operations
189
190(define (compile-egg-info eggfile info version platform mode)
191 (let ((exts '())
192 (prgs '())
193 (objs '())
194 (data '())
195 (genfiles '())
196 (cinc '())
197 (scminc '())
198 (target #f)
199 (src #f)
200 (files '())
201 (ifiles '())
202 (cbuild #f)
203 (oname #f)
204 (link '())
205 (dest #f)
206 (sdeps '())
207 (cdeps '())
208 (lopts '())
209 (opts '())
210 (mods #f)
211 (lobjs '())
212 (tfile #f)
213 (ptfile #f)
214 (ifile #f)
215 (install #t)
216 (eggfile (locate-egg-file eggfile))
217 (objext (object-extension platform))
218 (arcext (archive-extension platform))
219 (exeext (executable-extension platform)))
220 (define (check-target t lst)
221 (when (member t lst)
222 (error "target multiply defined" t))
223 t)
224 (define (addfiles . filess)
225 (set! ifiles (concatenate (cons ifiles filess)))
226 files)
227 (define (checkfiles files target)
228 (when (null? files)
229 (warning "target has no files" target)))
230 (define (compile-component info)
231 (case (car info)
232 ((extension)
233 (fluid-let ((target (check-target (cadr info) exts))
234 (cdeps '())
235 (sdeps '())
236 (src #f)
237 (cbuild #f)
238 (link (if (null? link) default-extension-linkage link))
239 (tfile #f)
240 (ptfile #f)
241 (ifile #f)
242 (lopts lopts)
243 (lobjs '())
244 (oname #f)
245 (mods #f)
246 (opts opts))
247 (for-each compile-extension/program (cddr info))
248 (let ((dest (effective-destination-repository mode #t))
249 ;; Respect install-name if specified
250 (rtarget (or oname target)))
251 (when (eq? #t tfile) (set! tfile rtarget))
252 (when (eq? #t ifile) (set! ifile rtarget))
253 (addfiles
254 (if (memq 'static link)
255 (list (conc dest "/" rtarget
256 (if (null? lobjs)
257 objext
258 arcext))
259 (conc dest "/" rtarget +link-file-extension+))
260 '())
261 (if (memq 'dynamic link) (list (conc dest "/" rtarget ".so")) '())
262 (if tfile
263 (list (conc dest "/" tfile ".types"))
264 '())
265 (if ifile
266 (list (conc dest "/" ifile ".inline"))
267 '())
268 (import-libraries mods dest rtarget mode))
269 (set! exts
270 (cons (list target
271 dependencies: cdeps
272 source: src options: opts
273 link-options: lopts linkage: link custom: cbuild
274 mode: mode types-file: tfile inline-file: ifile
275 predefined-types: ptfile eggfile: eggfile
276 modules: (or mods (list rtarget))
277 source-dependencies: sdeps
278 link-objects: lobjs
279 output-file: rtarget)
280 exts)))))
281 ((installed-c-object c-object)
282 (fluid-let ((target (check-target (cadr info) exts))
283 (cdeps '())
284 (sdeps '())
285 (src #f)
286 (cbuild #f)
287 (link (if (null? link) default-extension-linkage link))
288 (oname #f)
289 (mods #f)
290 (install (eq? 'installed-c-object (car info)))
291 (opts opts))
292 (for-each compile-extension/program (cddr info))
293 (let ((dest (effective-destination-repository mode #t))
294 ;; Respect install-name if specified
295 (rtarget (or oname target)))
296 (when install
297 (addfiles (list (conc dest "/" rtarget objext))))
298 (set! objs
299 (cons (list target dependencies: cdeps source: src
300 options: opts
301 linkage: link custom: cbuild
302 mode: mode
303 eggfile: eggfile
304 source-dependencies: sdeps
305 output-file: rtarget)
306 objs)))))
307 ((data)
308 (fluid-let ((target (check-target (cadr info) data))
309 (dest #f)
310 (files '()))
311 (for-each compile-data/include (cddr info))
312 (checkfiles files target)
313 (let* ((dest (or (and dest (normalize-destination dest mode))
314 (if (eq? mode 'target)
315 default-sharedir
316 (override-prefix "/share" host-sharedir))))
317 (dest (normalize-pathname (conc dest "/"))))
318 (addfiles (map (cut conc dest <>) files)))
319 (set! data
320 (cons (list target dependencies: '() files: files
321 destination: dest mode: mode)
322 data))))
323 ((generated-source-file)
324 (fluid-let ((target (check-target (cadr info) data))
325 (src #f)
326 (cbuild #f)
327 (sdeps '())
328 (cdeps '()))
329 (for-each compile-extension/program (cddr info))
330 (unless cbuild
331 (error "generated source files need a custom build step" target))
332 (set! genfiles
333 (cons (list target dependencies: cdeps source: src
334 custom: cbuild source-dependencies: sdeps
335 eggfile: eggfile)
336 genfiles))))
337 ((c-include)
338 (fluid-let ((target (check-target (cadr info) cinc))
339 (dest #f)
340 (files '()))
341 (for-each compile-data/include (cddr info))
342 (checkfiles files target)
343 (let* ((dest (or (and dest (normalize-destination dest mode))
344 (if (eq? mode 'target)
345 default-incdir
346 (override-prefix "/include" host-incdir))))
347 (dest (normalize-pathname (conc dest "/"))))
348 (addfiles (map (cut conc dest <>) files)))
349 (set! cinc
350 (cons (list target dependencies: '() files: files
351 destination: dest mode: mode)
352 cinc))))
353 ((scheme-include)
354 (fluid-let ((target (check-target (cadr info) scminc))
355 (dest #f)
356 (files '()))
357 (checkfiles files target)
358 (for-each compile-data/include (cddr info))
359 (let* ((dest (or (and dest (normalize-destination dest mode))
360 (if (eq? mode 'target)
361 default-sharedir
362 (override-prefix "/share" host-sharedir))))
363 (dest (normalize-pathname (conc dest "/"))))
364 (addfiles (map (cut conc dest <>) files)))
365 (set! scminc
366 (cons (list target dependencies: '() files: files
367 destination: dest mode: mode)
368 scminc))))
369 ((program)
370 (fluid-let ((target (check-target (cadr info) prgs))
371 (cdeps '())
372 (sdeps '())
373 (cbuild #f)
374 (src #f)
375 (link (if (null? link) default-program-linkage link))
376 (lobjs '())
377 (lopts lopts)
378 (oname #f)
379 (opts opts))
380 (for-each compile-extension/program (cddr info))
381 (let ((dest (if (eq? mode 'target)
382 default-bindir
383 (override-prefix "/bin" host-bindir)))
384 ;; Respect install-name if specified
385 (rtarget (or oname target)))
386 (addfiles (list (conc dest "/" rtarget exeext)))
387 (set! prgs
388 (cons (list target dependencies: cdeps
389 source: src options: opts
390 link-options: lopts linkage: link
391 custom: cbuild
392 mode: mode output-file: rtarget
393 source-dependencies: sdeps
394 link-objects: lobjs
395 eggfile: eggfile)
396 prgs)))))
397 (else (compile-common info compile-component 'component))))
398 (define (compile-extension/program info)
399 (case (car info)
400 ((linkage)
401 (set! link (cdr info)))
402 ((types-file)
403 (set! tfile
404 (cond ((null? (cdr info)) #t)
405 ((not (pair? (cadr info)))
406 (arg info 1 name?))
407 (else
408 (set! ptfile #t)
409 (set! tfile
410 (or (null? (cdadr info))
411 (arg (cadr info) 1 name?)))))))
412 ((objects)
413 (let ((los (map ->string (cdr info))))
414 (set! lobjs (append lobjs los))
415 (set! cdeps (append cdeps (map ->dep los)))))
416 ((inline-file)
417 (set! ifile (or (null? (cdr info)) (arg info 1 name?))))
418 ((custom-build)
419 (set! cbuild (->string (arg info 1 name?))))
420 ((csc-options)
421 (set! opts
422 (apply append
423 opts
424 (map parse-custom-config (cdr info)))))
425 ((link-options)
426 (set! lopts
427 (apply append
428 lopts
429 (map parse-custom-config (cdr info)))))
430 ((source)
431 (set! src (->string (arg info 1 name?))))
432 ((install-name)
433 (set! oname (->string (arg info 1 name?))))
434 ((modules)
435 (set! mods (map library-id (cdr info))))
436 ((component-dependencies)
437 (set! cdeps (append cdeps (map ->dep (cdr info)))))
438 ((source-dependencies)
439 (set! sdeps (append sdeps (map ->dep (cdr info)))))
440 (else (compile-common info compile-extension/program 'extension/program))))
441 (define (compile-common info walk context)
442 (case (car info)
443 ((target)
444 (when (eq? mode 'target)
445 (for-each walk (cdr info))))
446 ((host)
447 (when (eq? mode 'host)
448 (for-each walk (cdr info))))
449 ((error)
450 (apply error (cdr info)))
451 ((cond-expand)
452 (compile-cond-expand info walk))
453 (else
454 (fprintf (current-error-port) "\nWarning (~a): property `~a' invalid or in wrong context (~a)\n\n" eggfile (car info) context))))
455 (define (compile-data/include info)
456 (case (car info)
457 ((destination)
458 (set! dest (->string (arg info 1 name?))))
459 ((files)
460 (set! files (append files (map ->string (cdr info)))))
461 (else (compile-common info compile-data/include 'data/include))))
462 (define (compile-options info)
463 (define (custom info)
464 (map parse-custom-config info))
465 (case (car info)
466 ((csc-options) (set! opts (apply append opts (custom (cdr info)))))
467 ((link-options) (set! lopts (apply append lopts (custom (cdr info)))))
468 ((linkage) (set! link (apply append link (custom (cdr info)))))
469 (else (error "invalid component-options specification" info))))
470 (define (compile-cond-expand info walk)
471 (let loop ((clauses (cdr info)))
472 (cond ((null? clauses)
473 (error "no matching clause in `cond-expand' form"
474 info))
475 ((or (eq? 'else (caar clauses))
476 (check-condition (caar clauses) mode link))
477 (for-each walk (cdar clauses)))
478 (else (loop (cdr clauses))))))
479 (define (->dep x)
480 (if (name? x)
481 (if (symbol? x) x (string->symbol x))
482 (error "invalid dependency" x)))
483 (define (compile info)
484 (case (car info)
485 ((synopsis dependencies test-dependencies category version author maintainer
486 license build-dependencies foreign-dependencies platform
487 distribution-files) #f)
488 ((components) (for-each compile-component (cdr info)))
489 ((component-options)
490 (for-each compile-options (cdr info)))
491 (else (compile-common info compile 'toplevel))))
492 (define (arg info n #!optional (pred (constantly #t)))
493 (when (< (length info) n)
494 (error "missing argument" info n))
495 (let ((x (list-ref info n)))
496 (unless (pred x)
497 (error "argument has invalid type" x))
498 x))
499 (define (name? x) (or (string? x) (symbol? x)))
500 (define dep=? equal?)
501 (define (filter pred lst)
502 (cond ((null? lst) '())
503 ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
504 (else (filter pred (cdr lst)))))
505 (define (filter-deps name deps)
506 (filter (lambda (dep)
507 (and (symbol? dep)
508 (or (assq dep exts)
509 (assq dep objs)
510 (assq dep data)
511 (assq dep cinc)
512 (assq dep scminc)
513 (assq dep genfiles)
514 (assq dep prgs)
515 (error "unknown component dependency" dep))))
516 deps))
517 ;; collect information
518 (for-each compile info)
519 ;; sort topologically, by dependencies
520 (let* ((all (append prgs exts objs genfiles))
521 (order (reverse (sort-dependencies
522 (map (lambda (dep)
523 (cons (car dep)
524 (filter-deps (car dep)
525 (get-keyword dependencies: (cdr dep)))))
526 all)
527 dep=?))))
528 ;; generate + return build/install commands
529 (values
530 ;; build commands
531 (append-map
532 (lambda (id)
533 (cond ((assq id exts) =>
534 (lambda (data)
535 (let ((link (get-keyword linkage: (cdr data)))
536 (mods (get-keyword modules: (cdr data))))
537 (append (if (memq 'dynamic link)
538 (list (apply compile-dynamic-extension data))
539 '())
540 (if (memq 'static link)
541 ;; if compiling both static + dynamic, override
542 ;; modules/types-file/inline-file properties to
543 ;; avoid generating things twice:
544 (list (apply compile-static-extension
545 (if (memq 'dynamic link)
546 (cons (car data)
547 (append '(modules: #f
548 types-file: #f
549 inline-file: #f)
550 (cdr data)))
551 data)))
552 '())
553 (if (uses-compiled-import-library? mode)
554 (map (lambda (mod)
555 (apply compile-import-library
556 mod (cdr data))) ; override name
557 mods)
558 '())))))
559 ((assq id prgs) =>
560 (lambda (data)
561 (let ((link (get-keyword linkage: (cdr data))))
562 (append (if (memq 'dynamic link)
563 (list (apply compile-dynamic-program data))
564 '())
565 (if (memq 'static link)
566 (list (apply compile-static-program data))
567 '())))))
568 ((assq id objs) =>
569 (lambda (data)
570 (let ((link (get-keyword linkage: (cdr data))))
571 (append (if (memq 'dynamic link)
572 (list (apply compile-dynamic-object data))
573 '())
574 (if (memq 'static link)
575 (list (apply compile-static-object data))
576 '())))))
577 ((assq id genfiles) =>
578 (lambda (data)
579 (list (apply compile-generated-file data))))
580 ((or (assq id data)
581 (assq id cinc)
582 (assq id scminc))
583 '()) ;; nothing to build for data components
584 (else (error "Error in chicken-install, don't know how to build component" id))))
585 order)
586 ;; installation commands
587 (append
588 (append-map
589 (lambda (ext)
590 (let ((link (get-keyword linkage: (cdr ext)))
591 (mods (get-keyword modules: (cdr ext))))
592 (append
593 (if (memq 'static link)
594 (list (apply install-static-extension ext))
595 '())
596 (if (memq 'dynamic link)
597 (list (apply install-dynamic-extension ext))
598 '())
599 (if (and (memq 'dynamic link)
600 (uses-compiled-import-library? (get-keyword mode: ext)))
601 (map (lambda (mod)
602 (apply install-import-library
603 mod (cdr ext))) ; override name
604 mods)
605 (map (lambda (mod)
606 (apply install-import-library-source
607 mod (cdr ext))) ; s.a.
608 mods))
609 (if (get-keyword types-file: (cdr ext))
610 (list (apply install-types-file ext))
611 '())
612 (if (get-keyword inline-file: (cdr ext))
613 (list (apply install-inline-file ext))
614 '()))))
615 exts)
616 (map (lambda (obj) (apply install-object obj)) objs)
617 (map (lambda (prg) (apply install-program prg)) prgs)
618 (map (lambda (data) (apply install-data data)) data)
619 (map (lambda (cinc) (apply install-c-include cinc)) cinc)
620 (map (lambda (scminc) (apply install-data scminc)) scminc))
621 ;; augmented egg-info
622 (append `((installed-files ,@ifiles))
623 (if version `((version ,version)) '())
624 info)))))
625
626
627;;; shell code generation - build operations
628
629(define ((compile-static-extension name #!key mode dependencies
630 source-dependencies
631 source (options '())
632 predefined-types eggfile
633 link-objects modules
634 custom types-file inline-file)
635 srcdir platform)
636 (let* ((cmd (or (custom-cmd custom srcdir platform)
637 default-csc))
638 (sname (prefix srcdir name))
639 (tfile (prefix srcdir (conc types-file ".types")))
640 (ifile (prefix srcdir (conc inline-file ".inline")))
641 (lfile (conc sname +link-file-extension+))
642 (opts (append (if (null? options)
643 default-static-compilation-options
644 options)
645 (if (and types-file
646 (not predefined-types))
647 (list "-emit-types-file" tfile)
648 '())
649 (if inline-file
650 (list "-emit-inline-file" ifile)
651 '())))
652 (out1 (conc sname ".static"))
653 (out2 (target-file (conc out1
654 (object-extension platform))
655 mode))
656 (out3 (if (null? link-objects)
657 out2
658 (target-file (conc out1
659 (archive-extension platform))
660 mode)))
661 (imps (map (lambda (m)
662 (prefix srcdir (conc m ".import.scm")))
663 (or modules '())))
664 (targets (append (list out3 lfile)
665 (maybe types-file tfile)
666 (maybe inline-file ifile)
667 imps))
668 (src (or source (conc name ".scm"))))
669 (when custom
670 (prepare-custom-command cmd platform))
671 (print-build-command targets
672 `(,@(filelist srcdir source-dependencies) ,src ,eggfile
673 ,@(if custom (list cmd) '())
674 ,@(get-dependency-targets dependencies))
675 `(,@(if custom '("sh") '())
676 ,cmd ,@(if keep-generated-files '("-k") '())
677 "-regenerate-import-libraries"
678 ,@(if modules '("-J") '()) "-M"
679 "-setup-mode" "-static" "-I" ,srcdir
680 "-emit-link-file" ,lfile
681 ,@(if (eq? mode 'host) '("-host") '())
682 "-D" "compiling-extension"
683 "-c" "-unit" ,name
684 "-D" "compiling-static-extension"
685 "-C" ,(conc "-I" srcdir)
686 ,@opts ,src "-o" ,out2)
687 platform)
688 (when (pair? link-objects)
689 (let ((lobjs (filelist srcdir
690 (map (cut conc <> ".static" (object-extension platform))
691 link-objects))))
692 (print-build-command (list out3)
693 `(,out2 ,@lobjs)
694 `(,target-librarian ,target-librarian-options ,out3 ,out2 ,@lobjs)
695 platform)))
696 (print-end-command platform)))
697
698(define ((compile-dynamic-extension name #!key mode mode dependencies
699 source (options '())
700 (link-options '())
701 predefined-types eggfile
702 link-objects
703 source-dependencies modules
704 custom types-file inline-file)
705 srcdir platform)
706 (let* ((cmd (or (custom-cmd custom srcdir platform)
707 default-csc))
708 (sname (prefix srcdir name))
709 (tfile (prefix srcdir (conc types-file ".types")))
710 (ifile (prefix srcdir (conc inline-file ".inline")))
711 (opts (append (if (null? options)
712 default-dynamic-compilation-options
713 options)
714 (if (and types-file
715 (not predefined-types))
716 (list "-emit-types-file" tfile)
717 '())
718 (if inline-file
719 (list "-emit-inline-file" ifile)
720 '())))
721 (out (target-file (conc sname ".so") mode))
722 (src (or source (conc name ".scm")))
723 (lobjs (map (lambda (lo)
724 (target-file (conc lo
725 (object-extension platform))
726 mode))
727 link-objects))
728 (imps (map (lambda (m)
729 (prefix srcdir (conc m ".import.scm")))
730 modules))
731 (targets (append (list out)
732 (maybe inline-file ifile)
733 (maybe (and types-file
734 (not predefined-types)) tfile)
735 imps)))
736 (add-dependency-target name out)
737 (when custom
738 (prepare-custom-command cmd platform))
739 (print-build-command targets
740 `(,src ,eggfile ,@(if custom (list cmd) '())
741 ,@(filelist srcdir lobjs)
742 ,@(filelist srcdir source-dependencies)
743 ,@(get-dependency-targets dependencies))
744 `(,@(if custom '("sh") '())
745 ,cmd ,@(if keep-generated-files '("-k") '())
746 ,@(if (eq? mode 'host) '("-host") '())
747 "-D" "compiling-extension"
748 "-J" "-s" "-regenerate-import-libraries"
749 "-setup-mode" "-I" ,srcdir
750 "-C" ,(conc "-I" srcdir)
751 ,@opts
752 ,@link-options
753 ,src
754 ,@(filelist srcdir lobjs)
755 "-o" ,out)
756 platform)
757 (print-end-command platform)))
758
759(define ((compile-import-library name #!key mode
760 source-dependencies
761 (options '()) (link-options '()))
762 srcdir platform)
763 (let* ((cmd default-csc)
764 (sname (prefix srcdir name))
765 (opts (if (null? options)
766 default-import-library-compilation-options
767 options))
768 (out (target-file (conc sname ".import.so") mode))
769 (src (conc name ".import.scm")))
770 (print-build-command (list out)
771 ;; TODO: eggfile not part of dependencies?
772 `(,src #;,eggfile ,@(filelist srcdir source-dependencies))
773 `(,cmd ,@(if keep-generated-files '("-k") '())
774 "-setup-mode" "-s"
775 ,@(if (eq? mode 'host) '("-host") '())
776 "-I" ,srcdir "-C" ,(conc "-I" srcdir)
777 ,@opts ,@link-options
778 ,src
779 "-o" ,out)
780 platform)
781 (print-end-command platform)))
782
783(define ((compile-static-object name #!key mode dependencies
784 source-dependencies
785 source (options '())
786 eggfile custom)
787 srcdir platform)
788 (let* ((cmd (or (custom-cmd custom srcdir platform)
789 default-csc))
790 (sname (prefix srcdir name))
791 (ssname (and source (prefix srcdir source)))
792 (opts (if (null? options)
793 default-static-compilation-options
794 options))
795 (out (target-file (conc sname
796 ".static"
797 (object-extension platform))
798 mode))
799 (src (or ssname (conc sname ".c"))))
800 (when custom
801 (prepare-custom-command cmd platform))
802 (print-build-command (list out)
803 `(,@(filelist srcdir source-dependencies) ,src ,eggfile
804 ,@(if custom (list cmd) '())
805 ,@(get-dependency-targets dependencies))
806 `(,@(if custom '("sh") '())
807 ,cmd "-setup-mode" "-static" "-I" ,srcdir
808 ,@(if (eq? mode 'host) '("-host") '())
809 "-c" "-C" ,(conc "-I" srcdir)
810 ,@opts ,src "-o" ,out)
811 platform)
812 (print-end-command platform)))
813
814(define ((compile-dynamic-object name #!key mode mode dependencies
815 source (options '())
816 eggfile
817 source-dependencies
818 custom)
819 srcdir platform)
820 (let* ((cmd (or (custom-cmd custom srcdir platform)
821 default-csc))
822 (opts (if (null? options)
823 default-dynamic-compilation-options
824 options))
825 (sname (prefix srcdir name))
826 (ssname (and source (prefix srcdir source)))
827 (out (target-file (conc sname
828 (object-extension platform))
829 mode))
830 (src (or ssname (conc sname ".c"))))
831 (add-dependency-target name out)
832 (when custom
833 (prepare-custom-command cmd platform))
834 (print-build-command (list out)
835 `(,src ,eggfile ,@(if custom (list cmd) '())
836 ,@(filelist srcdir source-dependencies)
837 ,@(get-dependency-targets dependencies))
838 `(,@(if custom '("sh") '())
839 ,cmd ,@(if (eq? mode 'host) '("-host") '())
840 "-s" "-c" "-C" ,(conc "-I" srcdir)
841 ,@opts ,src "-o" ,out)
842 platform)
843 (print-end-command platform)))
844
845(define ((compile-dynamic-program name #!key source mode dependencies
846 (options '()) (link-options '())
847 source-dependencies
848 custom eggfile link-objects)
849 srcdir platform)
850 (let* ((cmd (or (custom-cmd custom srcdir platform)
851 default-csc))
852 (sname (prefix srcdir name))
853 (opts (if (null? options)
854 default-dynamic-compilation-options
855 options))
856 (out (target-file (conc sname
857 (executable-extension platform))
858 mode))
859 (lobjs (map (lambda (lo)
860 (target-file (conc lo
861 (object-extension platform))
862 mode))
863 link-objects))
864 (src (or source (conc name ".scm"))))
865 (when custom
866 (prepare-custom-command cmd platform))
867 (print-build-command (list out)
868 `(,src ,eggfile ,@(if custom (list cmd) '())
869 ,@(filelist srcdir source-dependencies)
870 ,@(filelist srcdir lobjs)
871 ,@(get-dependency-targets dependencies))
872 `(,@(if custom '("sh") '())
873 ,cmd ,@(if keep-generated-files '("-k") '())
874 "-setup-mode"
875 ,@(if (eq? mode 'host) '("-host") '())
876 "-I" ,srcdir
877 "-C" ,(conc "-I" srcdir)
878 ,@opts ,@link-options ,src
879 ,@(filelist srcdir lobjs)
880 "-o" ,out)
881 platform)
882 (print-end-command platform)))
883
884(define ((compile-static-program name #!key source dependencies
885 (options '()) (link-options '())
886 source-dependencies
887 custom mode eggfile link-objects)
888 srcdir platform)
889 (let* ((cmd (or (custom-cmd custom srcdir platform)
890 default-csc))
891 (sname (prefix srcdir name))
892 (opts (if (null? options)
893 default-static-compilation-options
894 options))
895 (out (target-file (conc sname
896 (executable-extension platform))
897 mode))
898 (lobjs (map (lambda (lo)
899 (target-file (conc lo
900 (object-extension platform))
901 mode))
902 link-objects))
903 (src (or source (conc name ".scm"))))
904 (when custom
905 (prepare-custom-command cmd platform))
906 (print-build-command (list out)
907 `(,src ,eggfile ,@(if custom (list cmd) '())
908 ,@(filelist srcdir lobjs)
909 ,@(filelist srcdir source-dependencies)
910 ,@(get-dependency-targets dependencies))
911 `(,@(if custom '("sh") '())
912 ,cmd ,@(if keep-generated-files '("-k") '())
913 ,@(if (eq? mode 'host) '("-host") '())
914 "-static" "-setup-mode" "-I" ,srcdir
915 "-C" ,(conc "-I" srcdir)
916 ,@opts ,@link-options ,src
917 ,@(filelist srcdir lobjs)
918 "-o" ,out)
919 platform)
920 (print-end-command platform)))
921
922(define ((compile-generated-file name #!key source custom dependencies
923 source-dependencies eggfile)
924 srcdir platform)
925 (let ((cmd (custom-cmd custom srcdir platform))
926 (out (or source name)))
927 (add-dependency-target name out)
928 (prepare-custom-command cmd platform)
929 (print-build-command (list out)
930 (append
931 (filelist srcdir source-dependencies)
932 (get-dependency-targets dependencies))
933 `("sh" ,cmd ,eggfile)
934 platform)
935 (print-end-command platform)))
936
937
938;; installation operations
939
940(define ((install-static-extension name #!key mode output-file
941 link-objects)
942 srcdir platform)
943 (let* ((cmd (install-file-command platform))
944 (mkdir (mkdir-command platform))
945 (ext (if (null? link-objects)
946 (object-extension platform)
947 (archive-extension platform)))
948 (sname (prefix srcdir name))
949 (out (qs* (target-file (conc sname ".static" ext) mode)))
950 (outlnk (qs* (conc sname +link-file-extension+)))
951 (dest (effective-destination-repository mode))
952 (dfile (qs* dest))
953 (ddir (shell-variable "DESTDIR")))
954 (print "\n" mkdir " " ddir dfile)
955 (print cmd " " out " " ddir
956 (qs* (conc dest "/" output-file ext)))
957 (print cmd " " outlnk " " ddir
958 (qs* (conc dest "/" output-file +link-file-extension+)))
959 (print-end-command platform)))
960
961(define ((install-dynamic-extension name #!key mode (ext ".so")
962 output-file)
963 srcdir platform)
964 (let* ((cmd (install-executable-command platform))
965 (mkdir (mkdir-command platform))
966 (sname (prefix srcdir name))
967 (out (qs* (target-file (conc sname ext) mode)))
968 (dest (effective-destination-repository mode))
969 (dfile (qs* dest))
970 (ddir (shell-variable "DESTDIR"))
971 (destf (qs* (conc dest "/" output-file ext))))
972 (print "\n" mkdir " " ddir dfile)
973 (print cmd " " out " " ddir destf)
974 (print-end-command platform)))
975
976(define ((install-import-library name #!key mode)
977 srcdir platform)
978 ((install-dynamic-extension name mode: mode ext: ".import.so"
979 output-file: name)
980 srcdir platform))
981
982(define ((install-import-library-source name #!key mode)
983 srcdir platform)
984 (let* ((cmd (install-file-command platform))
985 (mkdir (mkdir-command platform))
986 (sname (prefix srcdir name))
987 (out (qs* (target-file (conc sname ".import.scm") mode)))
988 (dest (effective-destination-repository mode))
989 (dfile (qs* dest))
990 (ddir (shell-variable "DESTDIR")))
991 (print "\n" mkdir " " ddir dfile)
992 (print cmd " " out " " ddir
993 (qs* (conc dest "/" name ".import.scm")))
994 (print-end-command platform)))
995
996(define ((install-types-file name #!key mode types-file)
997 srcdir platform)
998 (let* ((cmd (install-file-command platform))
999 (mkdir (mkdir-command platform))
1000 (out (qs* (prefix srcdir (conc types-file ".types"))))
1001 (dest (effective-destination-repository mode))
1002 (dfile (qs* dest))
1003 (ddir (shell-variable "DESTDIR")))
1004 (print "\n" mkdir " " ddir dfile)
1005 (print cmd " " out " " ddir
1006 (qs* (conc dest "/" types-file ".types")))
1007 (print-end-command platform)))
1008
1009(define ((install-inline-file name #!key mode inline-file)
1010 srcdir platform)
1011 (let* ((cmd (install-file-command platform))
1012 (mkdir (mkdir-command platform))
1013 (out (qs* (prefix srcdir (conc inline-file ".inline"))))
1014 (dest (effective-destination-repository mode))
1015 (dfile (qs* dest))
1016 (ddir (shell-variable "DESTDIR")))
1017 (print "\n" mkdir " " ddir dfile)
1018 (print cmd " " out " " ddir
1019 (qs* (conc dest "/" inline-file ".inline")))
1020 (print-end-command platform)))
1021
1022(define ((install-program name #!key mode output-file) srcdir platform)
1023 (let* ((cmd (install-executable-command platform))
1024 (mkdir (mkdir-command platform))
1025 (ext (executable-extension platform))
1026 (sname (prefix srcdir name))
1027 (out (qs* (target-file (conc sname ext) mode)))
1028 (dest (if (eq? mode 'target)
1029 default-bindir
1030 (override-prefix "/bin" host-bindir)))
1031 (dfile (qs* dest))
1032 (ddir (shell-variable "DESTDIR"))
1033 (destf (qs* (conc dest "/" output-file ext))))
1034 (print "\n" mkdir " " ddir dfile)
1035 (print cmd " " out " " ddir destf)
1036 (print-end-command platform)))
1037
1038(define ((install-object name #!key mode output-file) srcdir platform)
1039 (let* ((cmd (install-file-command platform))
1040 (mkdir (mkdir-command platform))
1041 (ext (object-extension platform))
1042 (sname (prefix srcdir name))
1043 (out (qs* (target-file (conc sname ext) mode)))
1044 (dest (effective-destination-repository mode))
1045 (dfile (qs* dest))
1046 (ddir (shell-variable "DESTDIR")))
1047 (print "\n" mkdir " " ddir dfile)
1048 (print cmd " " out " " ddir
1049 (qs* (conc dest "/" output-file ext)))
1050 (print-end-command platform)))
1051
1052(define (install-random-files dest files mode srcdir platform)
1053 (let* ((fcmd (install-file-command platform))
1054 (dcmd (copy-directory-command platform))
1055 (root (string-append srcdir "/"))
1056 (mkdir (mkdir-command platform))
1057 (sfiles (map (cut prefix srcdir <>) files))
1058 (dfile (qs* dest))
1059 (ddir (shell-variable "DESTDIR")))
1060 (print "\n" mkdir " " ddir dfile)
1061 (let-values (((ds fs) (partition directory? sfiles)))
1062 (for-each
1063 (lambda (d)
1064 (let* ((ds (strip-dir-prefix srcdir d))
1065 (fdir (pathname-directory ds)))
1066 (when fdir
1067 (print mkdir " " ddir
1068 (qs* (make-pathname dest fdir))))
1069 (print dcmd " " (qs* d)
1070 " " ddir
1071 (if fdir
1072 (qs* (make-pathname dest fdir))
1073 dfile))
1074 (print-end-command platform)))
1075 ds)
1076 (when (pair? fs)
1077 (for-each
1078 (lambda (f)
1079 (let* ((fs (strip-dir-prefix srcdir f))
1080 (fdir (pathname-directory fs)))
1081 (when fdir
1082 (print mkdir " " ddir
1083 (qs* (make-pathname dest fdir))))
1084 (print fcmd " " (qs* f)
1085 " " ddir
1086 (if fdir
1087 (qs* (make-pathname dest fdir))
1088 dfile)))
1089 (print-end-command platform))
1090 fs)))))
1091
1092(define ((install-data name #!key files destination mode)
1093 srcdir platform)
1094 (install-random-files (or destination
1095 (if (eq? mode 'target)
1096 default-sharedir
1097 (override-prefix "/share"
1098 host-sharedir)))
1099 files mode srcdir platform))
1100
1101(define ((install-c-include name #!key deps files destination mode)
1102 srcdir platform)
1103 (install-random-files (or destination
1104 (if (eq? mode 'target)
1105 default-incdir
1106 (override-prefix "/include"
1107 host-incdir)))
1108 files mode srcdir platform))
1109
1110;; manage dependency-targets
1111
1112(define (add-dependency-target target output)
1113 (cond ((assq target dependency-targets) =>
1114 (lambda (a)
1115 (set-cdr! a output)))
1116 (else (set! dependency-targets
1117 (cons (cons target output) dependency-targets)))))
1118
1119(define (get-dependency-targets targets)
1120 (append-map
1121 (lambda (t)
1122 (cond ((assq t dependency-targets) => (lambda (a) (list (cdr a))))
1123 (else '())))
1124 targets))
1125
1126
1127;;; Generate shell or batch commands from abstract build/install operations
1128
1129(define (generate-shell-commands platform cmds dest srcdir prefix suffix keep)
1130 (fluid-let ((keep-generated-files keep))
1131 (with-output-to-file dest
1132 (lambda ()
1133 (prefix platform)
1134 (print (cd-command platform) " " (qs* srcdir))
1135 (for-each
1136 (lambda (cmd) (cmd srcdir platform))
1137 cmds)
1138 (suffix platform)))))
1139
1140
1141;;; affixes for build- and install-scripts
1142
1143(define ((build-prefix mode name info) platform)
1144 (printf #<<EOF
1145#!/bin/sh~%
1146set -e
1147PATH=~a:$PATH
1148export CHICKEN_CC=~a
1149export CHICKEN_CXX=~a
1150export CHICKEN_CSC=~a
1151export CHICKEN_CSI=~a
1152
1153EOF
1154 (qs* default-bindir) (qs* default-cc)
1155 (qs* default-cxx) (qs* default-csc)
1156 (qs* default-csi)))
1157
1158(define ((build-suffix mode name info) platform)
1159 (printf #<<EOF
1160EOF
1161 ))
1162
1163(define ((install-prefix mode name info) platform)
1164 (printf #<<EOF
1165#!/bin/sh~%
1166set -e
1167
1168EOF
1169 ))
1170
1171(define ((install-suffix mode name info) platform)
1172 (let* ((infostr (with-output-to-string (cut pp info)))
1173 (dcmd (remove-file-command platform))
1174 (mkdir (mkdir-command platform))
1175 (dir (destination-repository mode))
1176 (qdir (qs* dir))
1177 (dest (qs* (make-pathname dir name +egg-info-extension+)))
1178 (ddir (shell-variable "DESTDIR")))
1179 (printf #<<EOF
1180
1181~a ~a~a
1182~a ~a~a
1183cat >~a~a <<'ENDINFO'
1184~aENDINFO~%
1185EOF
1186 mkdir ddir qdir
1187 dcmd ddir dest
1188 ddir dest infostr)))
1189
1190;;; some utilities for mangling + quoting
1191
1192(define (qs* arg)
1193 (qs (->string arg)))
1194
1195(define (prefix dir name)
1196 (make-pathname dir (->string name)))
1197
1198(define (system+ str platform)
1199 (system (if (eq? platform 'windows)
1200 (string-append "sh -c \"" str "\"")
1201 str)))
1202
1203(define (target-file fname mode)
1204 (if (eq? mode 'target) (string-append fname ".target") fname))
1205
1206(define (joins strs platform)
1207 (string-intersperse (map qs* strs) " "))
1208
1209(define (filelist dir lst)
1210 (map (cut prefix dir <>) lst))
1211
1212(define (shell-variable var)
1213 (string-append "\"${" var "}\""))
1214
1215(define prepare-custom-command void)
1216
1217(define (custom-cmd custom srcdir platform)
1218 (and custom (prefix srcdir custom)))
1219
1220(define (print-build-command targets sources command-and-args platform)
1221 (print "\n" (qs* default-builder) " "
1222 (joins targets platform)
1223 " : " (joins sources platform) " "
1224 " : " (joins command-and-args platform)))
1225
1226(define print-end-command void)
1227
1228(define (strip-dir-prefix prefix fname)
1229 (let* ((plen (string-length prefix))
1230 (p1 (substring fname 0 plen)))
1231 (assert (string=? prefix p1) "wrong prefix" prefix p1)
1232 (substring fname (add1 plen))))
1233
1234(define (maybe f x) (if f (list x) '()))
1235
1236(define (ensure-line-limit str lim)
1237 (when (>= (string-length str) lim)
1238 (error "line length exceeds platform limit: " str))
1239 str)