~ chicken-core (chicken-5) /egg-compile.scm
Trap1;;;; egg-info processing and compilation2;3; Copyright (c) 2017-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; 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 promote14; 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 EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627(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"))3637(define default-program-linkage38 (if staticbuild '(static) '(dynamic)))3940(define default-extension-linkage41 (if staticbuild '(static) '(static dynamic)))4243(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")5051(define keep-generated-files #f)52(define dependency-targets '())535455;;; some utilities5657(define override-prefix58 (let ((prefix (get-environment-variable "CHICKEN_INSTALL_PREFIX")))59 (lambda (dir default)60 (if prefix61 (string-append prefix dir)62 default))))6364(define (object-extension platform)65 (case platform66 ((unix) +unix-object-extension+)67 ((windows) +windows-object-extension+)))6869(define (archive-extension platform)70 (case platform71 ((unix) +unix-archive-extension+)72 ((windows) +windows-archive-extension+)))7374(define (executable-extension platform)75 (case platform76 ((unix) +unix-executable-extension+)77 ((windows) +windows-executable-extension+)))7879(define (copy-directory-command platform)80 (case platform81 ((unix) "cp -r")82 ((windows) "xcopy /y /i /e")))8384(define (copy-file-command platform)85 (case platform86 ((unix) "cp")87 ((windows) "copy /y")))8889(define (mkdir-command platform)90 (case platform91 ((unix) "mkdir -p")92 ((windows) "mkdir")))9394(define (install-executable-command platform)95 (case platform96 ((windows) (copy-file-command 'windows))97 (else98 (string-append default-install-program " "99 default-install-program-executable-flags))))100101(define (install-file-command platform)102 (case platform103 ((windows) (copy-file-command 'windows))104 (else105 (string-append default-install-program " "106 default-install-program-data-flags))))107108(define (remove-file-command platform)109 (case platform110 ((unix) "rm -f")111 ((windows) "del /f /q")))112113(define (cd-command platform)114 (case platform115 ((unix) "cd")116 ((windows) "cd /d")))117118(define (uses-compiled-import-library? mode)119 (not (and (eq? mode 'host) staticbuild)))120121;; this one overrides "destination-repository" in egg-environment to allow use of122;; CHICKEN_INSTALL_PREFIX (via "override-prefix")123(define (effective-destination-repository mode #!optional run)124 (if (eq? 'target mode)125 (if run target-run-repo target-repo)126 (or (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")127 (override-prefix (string-append "/lib/chicken/" (number->string binary-version))128 host-repo))))129130;;; topological sort with cycle check131132(define (sort-dependencies dag eq)133 (condition-case (topological-sort dag eq)134 ((exn runtime cycle)135 (error "cyclic dependencies" dag))))136137138;;; collect import libraries for all modules139140(define (import-libraries mods dest rtarget mode)141 (define (implib name)142 (conc dest "/" name ".import."143 (if (uses-compiled-import-library? mode)144 "so"145 "scm")))146 (if mods147 (map implib mods)148 (list (implib rtarget))))149150151;;; normalize target path for "random files" (data, c-include, scheme-include)152153(define (normalize-destination dest mode)154 (let ((dest* (normalize-pathname dest)))155 (if (irregex-search '(: bos ".." ("\\/")) dest*)156 (error "destination must be relative to CHICKEN install prefix" dest)157 (normalize-pathname158 (make-pathname (if (eq? mode 'target)159 default-prefix160 (override-prefix "/" host-prefix))161 dest*)))))162163164;;; check condition in conditional clause165166(define (check-condition tst mode link)167 (define (fail x)168 (error "invalid conditional expression in `cond-expand' clause"169 x))170 (let walk ((x tst))171 (cond ((and (list? x) (pair? x))172 (cond ((and (eq? (car x) 'not) (= 2 (length x)))173 (not (walk (cadr x))))174 ((eq? 'and (car x)) (every walk (cdr x)))175 ((eq? 'or (car x)) (any walk (cdr x)))176 (else (fail x))))177 ((memq x '(dynamic static)) (memq x link))178 ((memq x '(target host)) (memq x mode))179 ((symbol? x) (feature? x))180 (else (fail x)))))181182183;;; compile an egg-information tree into abstract build/install operations184185(define (compile-egg-info eggfile info version platform mode)186 (let ((exts '())187 (prgs '())188 (objs '())189 (data '())190 (genfiles '())191 (cinc '())192 (scminc '())193 (target #f)194 (src #f)195 (files '())196 (ifiles '())197 (cbuild #f)198 (oname #f)199 (link '())200 (dest #f)201 (sdeps '())202 (cdeps '())203 (lopts '())204 (opts '())205 (mods #f)206 (lobjs '())207 (tfile #f)208 (ptfile #f)209 (ifile #f)210 (eggfile (locate-egg-file eggfile))211 (objext (object-extension platform))212 (arcext (archive-extension platform))213 (exeext (executable-extension platform)))214 (define (check-target t lst)215 (when (member t lst)216 (error "target multiply defined" t))217 t)218 (define (addfiles . filess)219 (set! ifiles (concatenate (cons ifiles filess)))220 files)221 (define (compile-component info)222 (case (car info)223 ((extension)224 (fluid-let ((target (check-target (cadr info) exts))225 (cdeps '())226 (sdeps '())227 (src #f)228 (cbuild #f)229 (link (if (null? link) default-extension-linkage link))230 (tfile #f)231 (ptfile #f)232 (ifile #f)233 (lopts lopts)234 (lobjs '())235 (oname #f)236 (mods #f)237 (opts opts))238 (for-each compile-extension/program (cddr info))239 (let ((dest (effective-destination-repository mode #t))240 ;; Respect install-name if specified241 (rtarget (or oname target)))242 (when (eq? #t tfile) (set! tfile rtarget))243 (when (eq? #t ifile) (set! ifile rtarget))244 (addfiles245 (if (memq 'static link)246 (list (conc dest "/" rtarget247 (if (null? lobjs)248 objext249 arcext))250 (conc dest "/" rtarget +link-file-extension+))251 '())252 (if (memq 'dynamic link) (list (conc dest "/" rtarget ".so")) '())253 (if tfile254 (list (conc dest "/" tfile ".types"))255 '())256 (if ifile257 (list (conc dest "/" ifile ".inline"))258 '())259 (import-libraries mods dest rtarget mode))260 (set! exts261 (cons (list target262 dependencies: cdeps263 source: src options: opts264 link-options: lopts linkage: link custom: cbuild265 mode: mode types-file: tfile inline-file: ifile266 predefined-types: ptfile eggfile: eggfile267 modules: (or mods (list rtarget))268 source-dependencies: sdeps269 link-objects: lobjs270 output-file: rtarget)271 exts)))))272 ((c-object)273 (fluid-let ((target (check-target (cadr info) exts))274 (cdeps '())275 (sdeps '())276 (src #f)277 (cbuild #f)278 (link (if (null? link) default-extension-linkage link))279 (oname #f)280 (mods #f)281 (opts opts))282 (for-each compile-extension/program (cddr info))283 (let ((dest (effective-destination-repository mode #t))284 ;; Respect install-name if specified285 (rtarget (or oname target)))286 (set! objs287 (cons (list target dependencies: cdeps source: src288 options: opts289 linkage: link custom: cbuild290 mode: mode291 eggfile: eggfile292 source-dependencies: sdeps293 output-file: rtarget)294 objs)))))295 ((data)296 (fluid-let ((target (check-target (cadr info) data))297 (dest #f)298 (files '()))299 (for-each compile-data/include (cddr info))300 (let* ((dest (or (and dest (normalize-destination dest mode))301 (if (eq? mode 'target)302 default-sharedir303 (override-prefix "/share" host-sharedir))))304 (dest (normalize-pathname (conc dest "/"))))305 (addfiles (map (cut conc dest <>) files)))306 (set! data307 (cons (list target dependencies: '() files: files308 destination: dest mode: mode)309 data))))310 ((generated-source-file)311 (fluid-let ((target (check-target (cadr info) data))312 (src #f)313 (cbuild #f)314 (sdeps '())315 (cdeps '()))316 (for-each compile-extension/program (cddr info))317 (unless cbuild318 (error "generated source files need a custom build step" target))319 (set! genfiles320 (cons (list target dependencies: cdeps source: src321 custom: cbuild source-dependencies: sdeps322 eggfile: eggfile)323 genfiles))))324 ((c-include)325 (fluid-let ((target (check-target (cadr info) cinc))326 (dest #f)327 (files '()))328 (for-each compile-data/include (cddr info))329 (let* ((dest (or (and dest (normalize-destination dest mode))330 (if (eq? mode 'target)331 default-incdir332 (override-prefix "/include" host-incdir))))333 (dest (normalize-pathname (conc dest "/"))))334 (addfiles (map (cut conc dest <>) files)))335 (set! cinc336 (cons (list target dependencies: '() files: files337 destination: dest mode: mode)338 cinc))))339 ((scheme-include)340 (fluid-let ((target (check-target (cadr info) scminc))341 (dest #f)342 (files '()))343 (for-each compile-data/include (cddr info))344 (let* ((dest (or (and dest (normalize-destination dest mode))345 (if (eq? mode 'target)346 default-sharedir347 (override-prefix "/share" host-sharedir))))348 (dest (normalize-pathname (conc dest "/"))))349 (addfiles (map (cut conc dest <>) files)))350 (set! scminc351 (cons (list target dependencies: '() files: files352 destination: dest mode: mode)353 scminc))))354 ((program)355 (fluid-let ((target (check-target (cadr info) prgs))356 (cdeps '())357 (sdeps '())358 (cbuild #f)359 (src #f)360 (link (if (null? link) default-program-linkage link))361 (lobjs '())362 (lopts lopts)363 (oname #f)364 (opts opts))365 (for-each compile-extension/program (cddr info))366 (let ((dest (if (eq? mode 'target)367 default-bindir368 (override-prefix "/bin" host-bindir)))369 ;; Respect install-name if specified370 (rtarget (or oname target)))371 (addfiles (list (conc dest "/" rtarget exeext)))372 (set! prgs373 (cons (list target dependencies: cdeps374 source: src options: opts375 link-options: lopts linkage: link376 custom: cbuild377 mode: mode output-file: rtarget378 source-dependencies: sdeps379 link-objects: lobjs380 eggfile: eggfile)381 prgs)))))382 (else (compile-common info compile-component 'component))))383 (define (compile-extension/program info)384 (case (car info)385 ((linkage)386 (set! link (cdr info)))387 ((types-file)388 (set! tfile389 (cond ((null? (cdr info)) #t)390 ((not (pair? (cadr info)))391 (arg info 1 name?))392 (else393 (set! ptfile #t)394 (set! tfile395 (or (null? (cdadr info))396 (arg (cadr info) 1 name?)))))))397 ((objects)398 (let ((los (map ->string (cdr info))))399 (set! lobjs (append lobjs los))400 (set! cdeps (append cdeps (map ->dep los)))))401 ((inline-file)402 (set! ifile (or (null? (cdr info)) (arg info 1 name?))))403 ((custom-build)404 (set! cbuild (->string (arg info 1 name?))))405 ((csc-options)406 (set! opts (append opts (cdr info))))407 ((link-options)408 (set! lopts (append lopts (cdr info))))409 ((source)410 (set! src (->string (arg info 1 name?))))411 ((install-name)412 (set! oname (->string (arg info 1 name?))))413 ((modules)414 (set! mods (map library-id (cdr info))))415 ((component-dependencies)416 (set! cdeps (append cdeps (map ->dep (cdr info)))))417 ((source-dependencies)418 (set! sdeps (append sdeps (map ->dep (cdr info)))))419 (else (compile-common info compile-extension/program 'extension/program))))420 (define (compile-common info walk context)421 (case (car info)422 ((target)423 (when (eq? mode 'target)424 (for-each walk (cdr info))))425 ((host)426 (when (eq? mode 'host)427 (for-each walk (cdr info))))428 ((error)429 (apply error (cdr info)))430 ((cond-expand)431 (compile-cond-expand info walk))432 (else433 (fprintf (current-error-port) "\nWarning (~a): property `~a' invalid or in wrong context (~a)\n\n" eggfile (car info) context))))434 (define (compile-data/include info)435 (case (car info)436 ((destination)437 (set! dest (->string (arg info 1 name?))))438 ((files)439 (set! files (append files (map ->string (cdr info)))))440 (else (compile-common info compile-data/include 'data/include))))441 (define (compile-options info)442 (case (car info)443 ((csc-options) (set! opts (append opts (cdr info))))444 ((link-options) (set! lopts (append lopts (cdr info))))445 ((linkage) (set! link (append link (cdr info))))446 (else (error "invalid component-options specification" info))))447 (define (compile-cond-expand info walk)448 (let loop ((clauses (cdr info)))449 (cond ((null? clauses)450 (error "no matching clause in `cond-expand' form"451 info))452 ((or (eq? 'else (caar clauses))453 (check-condition (caar clauses) mode link))454 (for-each walk (cdar clauses)))455 (else (loop (cdr clauses))))))456 (define (->dep x)457 (if (name? x)458 (if (symbol? x) x (string->symbol x))459 (error "invalid dependency" x)))460 (define (compile info)461 (case (car info)462 ((synopsis dependencies test-dependencies category version author maintainer463 license build-dependencies foreign-dependencies platform464 distribution-files) #f)465 ((components) (for-each compile-component (cdr info)))466 ((component-options)467 (for-each compile-options (cdr info)))468 (else (compile-common info compile 'toplevel))))469 (define (arg info n #!optional (pred (constantly #t)))470 (when (< (length info) n)471 (error "missing argument" info n))472 (let ((x (list-ref info n)))473 (unless (pred x)474 (error "argument has invalid type" x))475 x))476 (define (name? x) (or (string? x) (symbol? x)))477 (define dep=? equal?)478 (define (filter pred lst)479 (cond ((null? lst) '())480 ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))481 (else (filter pred (cdr lst)))))482 (define (filter-deps name deps)483 (filter (lambda (dep)484 (and (symbol? dep)485 (or (assq dep exts)486 (assq dep objs)487 (assq dep data)488 (assq dep cinc)489 (assq dep scminc)490 (assq dep genfiles)491 (assq dep prgs)492 (error "unknown component dependency" dep))))493 deps))494 ;; collect information495 (for-each compile info)496 ;; sort topologically, by dependencies497 (let* ((all (append prgs exts objs genfiles))498 (order (reverse (sort-dependencies499 (map (lambda (dep)500 (cons (car dep)501 (filter-deps (car dep)502 (get-keyword dependencies: (cdr dep)))))503 all)504 dep=?))))505 ;; generate + return build/install commands506 (values507 ;; build commands508 (append-map509 (lambda (id)510 (cond ((assq id exts) =>511 (lambda (data)512 (let ((link (get-keyword linkage: (cdr data)))513 (mods (get-keyword modules: (cdr data))))514 (append (if (memq 'dynamic link)515 (list (apply compile-dynamic-extension data))516 '())517 (if (memq 'static link)518 ;; if compiling both static + dynamic, override519 ;; modules/types-file/inline-file properties to520 ;; avoid generating things twice:521 (list (apply compile-static-extension522 (if (memq 'dynamic link)523 (cons (car data)524 (append '(modules: #f525 types-file: #f526 inline-file: #f)527 (cdr data)))528 data)))529 '())530 (if (uses-compiled-import-library? mode)531 (map (lambda (mod)532 (apply compile-import-library533 mod (cdr data))) ; override name534 mods)535 '())))))536 ((assq id prgs) =>537 (lambda (data)538 (let ((link (get-keyword linkage: (cdr data))))539 (append (if (memq 'dynamic link)540 (list (apply compile-dynamic-program data))541 '())542 (if (memq 'static link)543 (list (apply compile-static-program data))544 '())))))545 ((assq id objs) =>546 (lambda (data)547 (let ((link (get-keyword linkage: (cdr data))))548 (append (if (memq 'dynamic link)549 (list (apply compile-dynamic-object data))550 '())551 (if (memq 'static link)552 (list (apply compile-static-object data))553 '())))))554 ((assq id genfiles) =>555 (lambda (data)556 (list (apply compile-generated-file data))))557 ((or (assq id data)558 (assq id cinc)559 (assq id scminc))560 '()) ;; nothing to build for data components561 (else (error "Error in chicken-install, don't know how to build component" id))))562 order)563 ;; installation commands564 (append565 (append-map566 (lambda (ext)567 (let ((link (get-keyword linkage: (cdr ext)))568 (mods (get-keyword modules: (cdr ext))))569 (append570 (if (memq 'static link)571 (list (apply install-static-extension ext))572 '())573 (if (memq 'dynamic link)574 (list (apply install-dynamic-extension ext))575 '())576 (if (and (memq 'dynamic link)577 (uses-compiled-import-library? (get-keyword mode: ext)))578 (map (lambda (mod)579 (apply install-import-library580 mod (cdr ext))) ; override name581 mods)582 (map (lambda (mod)583 (apply install-import-library-source584 mod (cdr ext))) ; s.a.585 mods))586 (if (get-keyword types-file: (cdr ext))587 (list (apply install-types-file ext))588 '())589 (if (get-keyword inline-file: (cdr ext))590 (list (apply install-inline-file ext))591 '()))))592 exts)593 (map (lambda (prg) (apply install-program prg)) prgs)594 (map (lambda (data) (apply install-data data)) data)595 (map (lambda (cinc) (apply install-c-include cinc)) cinc)596 (map (lambda (scminc) (apply install-data scminc)) scminc))597 ;; augmented egg-info598 (append `((installed-files ,@ifiles))599 (if version `((version ,version)) '())600 info)))))601602603;;; shell code generation - build operations604605(define ((compile-static-extension name #!key mode dependencies606 source-dependencies607 source (options '())608 predefined-types eggfile609 link-objects modules610 custom types-file inline-file)611 srcdir platform)612 (let* ((cmd (or (custom-cmd custom srcdir platform)613 default-csc))614 (sname (prefix srcdir name))615 (tfile (prefix srcdir (conc types-file ".types")))616 (ifile (prefix srcdir (conc inline-file ".inline")))617 (lfile (conc sname +link-file-extension+))618 (opts (append (if (null? options)619 default-static-compilation-options620 options)621 (if (and types-file622 (not predefined-types))623 (list "-emit-types-file" tfile)624 '())625 (if inline-file626 (list "-emit-inline-file" ifile)627 '())))628 (out1 (conc sname ".static"))629 (out2 (target-file (conc out1630 (object-extension platform))631 mode))632 (out3 (if (null? link-objects)633 out2634 (target-file (conc out1635 (archive-extension platform))636 mode)))637 (imps (map (lambda (m)638 (prefix srcdir (conc m ".import.scm")))639 (or modules '())))640 (targets (append (list out3 lfile)641 (maybe types-file tfile)642 (maybe inline-file ifile)643 imps))644 (src (or source (conc name ".scm"))))645 (when custom646 (prepare-custom-command cmd platform))647 (print-build-command targets648 `(,@(filelist srcdir source-dependencies) ,src ,eggfile649 ,@(if custom (list cmd) '())650 ,@(get-dependency-targets dependencies))651 `(,cmd ,@(if keep-generated-files '("-k") '())652 "-regenerate-import-libraries"653 ,@(if modules '("-J") '()) "-M"654 "-setup-mode" "-static" "-I" ,srcdir655 "-emit-link-file" ,lfile656 ,@(if (eq? mode 'host) '("-host") '())657 "-D" "compiling-extension"658 "-c" "-unit" ,name659 "-D" "compiling-static-extension"660 "-C" ,(conc "-I" srcdir)661 ,@opts ,src "-o" ,out2)662 platform)663 (when (pair? link-objects)664 (let ((lobjs (filelist srcdir665 (map (cut conc <> ".static" (object-extension platform))666 link-objects))))667 (print-build-command (list out3)668 `(,out2 ,@lobjs)669 `(,target-librarian ,(raw-arg target-librarian-options) ,out3 ,out2 ,@lobjs)670 platform)))671 (print-end-command platform)))672673(define ((compile-dynamic-extension name #!key mode mode dependencies674 source (options '())675 (link-options '())676 predefined-types eggfile677 link-objects678 source-dependencies modules679 custom types-file inline-file)680 srcdir platform)681 (let* ((cmd (or (custom-cmd custom srcdir platform)682 default-csc))683 (sname (prefix srcdir name))684 (tfile (prefix srcdir (conc types-file ".types")))685 (ifile (prefix srcdir (conc inline-file ".inline")))686 (opts (append (if (null? options)687 default-dynamic-compilation-options688 options)689 (if (and types-file690 (not predefined-types))691 (list "-emit-types-file" tfile)692 '())693 (if inline-file694 (list "-emit-inline-file" ifile)695 '())))696 (out (target-file (conc sname ".so") mode))697 (src (or source (conc name ".scm")))698 (lobjs (map (lambda (lo)699 (target-file (conc lo700 (object-extension platform))701 mode))702 link-objects))703 (imps (map (lambda (m)704 (prefix srcdir (conc m ".import.scm")))705 modules))706 (targets (append (list out)707 (maybe inline-file ifile)708 (maybe (and types-file709 (not predefined-types)) tfile)710 imps)))711 (add-dependency-target name out)712 (when custom713 (prepare-custom-command cmd platform))714 (print-build-command targets715 `(,src ,eggfile ,@(if custom (list cmd) '())716 ,@(filelist srcdir lobjs)717 ,@(filelist srcdir source-dependencies)718 ,@(get-dependency-targets dependencies))719 `(,cmd ,@(if keep-generated-files '("-k") '())720 ,@(if (eq? mode 'host) '("-host") '())721 "-D" "compiling-extension"722 "-J" "-s" "-regenerate-import-libraries"723 "-setup-mode" "-I" ,srcdir724 "-C" ,(conc "-I" srcdir)725 ,@opts726 ,@link-options727 ,src728 ,@(filelist srcdir lobjs)729 "-o" ,out)730 platform)731 (print-end-command platform)))732733(define ((compile-import-library name #!key mode734 source-dependencies735 (options '()) (link-options '()))736 srcdir platform)737 (let* ((cmd default-csc)738 (sname (prefix srcdir name))739 (opts (if (null? options)740 default-import-library-compilation-options741 options))742 (out (target-file (conc sname ".import.so") mode))743 (src (conc name ".import.scm")))744 (print-build-command (list out)745 ;; TODO: eggfile not part of dependencies?746 `(,src #;,eggfile ,@(filelist srcdir source-dependencies))747 `(,cmd ,@(if keep-generated-files '("-k") '())748 "-setup-mode" "-s"749 ,@(if (eq? mode 'host) '("-host") '())750 "-I" ,srcdir "-C" ,(conc "-I" srcdir)751 ,@opts ,@link-options752 ,src753 "-o" ,out)754 platform)755 (print-end-command platform)))756757(define ((compile-static-object name #!key mode dependencies758 source-dependencies759 source (options '())760 eggfile custom)761 srcdir platform)762 (let* ((cmd (or (custom-cmd custom srcdir platform)763 default-csc))764 (sname (prefix srcdir name))765 (ssname (and source (prefix srcdir source)))766 (opts (if (null? options)767 default-static-compilation-options768 options))769 (out (target-file (conc sname770 ".static"771 (object-extension platform))772 mode))773 (src (or ssname (conc sname ".c"))))774 (when custom775 (prepare-custom-command cmd platform))776 (print-build-command (list out)777 `(,@(filelist srcdir source-dependencies) ,src ,eggfile778 ,@(if custom (list cmd) '())779 ,@(get-dependency-targets dependencies))780 `(,cmd "-setup-mode" "-static" "-I" ,srcdir781 ,@(if (eq? mode 'host) '("-host") '())782 "-c" "-C" ,(conc "-I" srcdir)783 ,@opts ,src "-o" ,out)784 platform)785 (print-end-command platform)))786787(define ((compile-dynamic-object name #!key mode mode dependencies788 source (options '())789 eggfile790 source-dependencies791 custom)792 srcdir platform)793 (let* ((cmd (or (custom-cmd custom srcdir platform)794 default-csc))795 (opts (if (null? options)796 default-dynamic-compilation-options797 options))798 (sname (prefix srcdir name))799 (ssname (and source (prefix srcdir source)))800 (out (target-file (conc sname801 (object-extension platform))802 mode))803 (src (or ssname (conc sname ".c"))))804 (add-dependency-target name out)805 (when custom806 (prepare-custom-command cmd platform))807 (print-build-command (list out)808 `(,src ,eggfile ,@(if custom (list cmd) '())809 ,@(filelist srcdir source-dependencies)810 ,@(get-dependency-targets dependencies))811 `(,cmd ,@(if (eq? mode 'host) '("-host") '())812 "-s" "-c" "-C" ,(conc "-I" srcdir)813 ,@opts ,src "-o" ,out)814 platform)815 (print-end-command platform)))816817(define ((compile-dynamic-program name #!key source mode dependencies818 (options '()) (link-options '())819 source-dependencies820 custom eggfile link-objects)821 srcdir platform)822 (let* ((cmd (or (custom-cmd custom srcdir platform)823 default-csc))824 (sname (prefix srcdir name))825 (opts (if (null? options)826 default-dynamic-compilation-options827 options))828 (out (target-file (conc sname829 (executable-extension platform))830 mode))831 (lobjs (map (lambda (lo)832 (target-file (conc lo833 (object-extension platform))834 mode))835 link-objects))836 (src (or source (conc name ".scm"))))837 (when custom838 (prepare-custom-command cmd platform))839 (print-build-command (list out)840 `(,src ,eggfile ,@(if custom (list cmd) '())841 ,@(filelist srcdir source-dependencies)842 ,@(filelist srcdir lobjs)843 ,@(get-dependency-targets dependencies))844 `(,cmd ,@(if keep-generated-files '("-k") '())845 "-setup-mode"846 ,@(if (eq? mode 'host) '("-host") '())847 "-I" ,srcdir848 "-C" ,(conc "-I" srcdir)849 ,@opts ,@link-options ,src850 ,@(filelist srcdir lobjs)851 "-o" ,out)852 platform)853 (print-end-command platform)))854855(define ((compile-static-program name #!key source dependencies856 (options '()) (link-options '())857 source-dependencies858 custom mode eggfile link-objects)859 srcdir platform)860 (let* ((cmd (or (custom-cmd custom srcdir platform)861 default-csc))862 (sname (prefix srcdir name))863 (opts (if (null? options)864 default-static-compilation-options865 options))866 (out (target-file (conc sname867 (executable-extension platform))868 mode))869 (lobjs (map (lambda (lo)870 (target-file (conc lo871 (object-extension platform))872 mode))873 link-objects))874 (src (or source (conc name ".scm"))))875 (when custom876 (prepare-custom-command cmd platform))877 (print-build-command (list out)878 `(,src ,eggfile ,@(if custom (list cmd) '())879 ,@(filelist srcdir lobjs)880 ,@(filelist srcdir source-dependencies)881 ,@(get-dependency-targets dependencies))882 `(,cmd ,@(if keep-generated-files '("-k") '())883 ,@(if (eq? mode 'host) '("-host") '())884 "-static" "-setup-mode" "-I" ,srcdir885 "-C" ,(conc "-I" srcdir)886 ,@opts ,@link-options ,src887 ,@(filelist srcdir lobjs)888 "-o" ,out)889 platform)890 (print-end-command platform)))891892(define ((compile-generated-file name #!key source custom dependencies893 source-dependencies eggfile)894 srcdir platform)895 (let ((cmd (custom-cmd custom srcdir platform))896 (out (or source name)))897 (add-dependency-target name out)898 (prepare-custom-command cmd platform)899 (print-build-command (list out)900 `(,cmd ,eggfile901 ,@(filelist srcdir source-dependencies)902 ,@(get-dependency-targets dependencies))903 (list cmd)904 platform)905 (print-end-command platform)))906907908;; installation operations909910(define ((install-static-extension name #!key mode output-file911 link-objects)912 srcdir platform)913 (let* ((cmd (install-file-command platform))914 (mkdir (mkdir-command platform))915 (ext (if (null? link-objects)916 (object-extension platform)917 (archive-extension platform)))918 (sname (prefix srcdir name))919 (out (qs* (target-file (conc sname ".static" ext) mode)920 platform #t))921 (outlnk (qs* (conc sname +link-file-extension+) platform #t))922 (dest (effective-destination-repository mode))923 (dfile (qs* dest platform #t))924 (ddir (shell-variable "DESTDIR" platform)))925 (print "\n" mkdir " " ddir dfile)926 (print cmd " " out " " ddir927 (qs* (conc dest "/" output-file ext) platform #t))928 (print cmd " " outlnk " " ddir929 (qs* (conc dest "/" output-file +link-file-extension+)930 platform #t))931 (print-end-command platform)))932933(define ((install-dynamic-extension name #!key mode (ext ".so")934 output-file)935 srcdir platform)936 (let* ((cmd (install-executable-command platform))937 (mkdir (mkdir-command platform))938 (sname (prefix srcdir name))939 (out (qs* (target-file (conc sname ext) mode) platform #t))940 (dest (effective-destination-repository mode))941 (dfile (qs* dest platform #t))942 (ddir (shell-variable "DESTDIR" platform))943 (destf (qs* (conc dest "/" output-file ext) platform #t)))944 (print "\n" mkdir " " ddir dfile)945 (print cmd " " out " " ddir destf)946 (print-end-command platform)))947948(define ((install-import-library name #!key mode)949 srcdir platform)950 ((install-dynamic-extension name mode: mode ext: ".import.so"951 output-file: name)952 srcdir platform))953954(define ((install-import-library-source name #!key mode)955 srcdir platform)956 (let* ((cmd (install-file-command platform))957 (mkdir (mkdir-command platform))958 (sname (prefix srcdir name))959 (out (qs* (target-file (conc sname ".import.scm") mode)960 platform #t))961 (dest (effective-destination-repository mode))962 (dfile (qs* dest platform #t))963 (ddir (shell-variable "DESTDIR" platform)))964 (print "\n" mkdir " " ddir dfile)965 (print cmd " " out " " ddir966 (qs* (conc dest "/" name ".import.scm") platform #t))967 (print-end-command platform)))968969(define ((install-types-file name #!key mode types-file)970 srcdir platform)971 (let* ((cmd (install-file-command platform))972 (mkdir (mkdir-command platform))973 (out (qs* (prefix srcdir (conc types-file ".types"))974 platform #t))975 (dest (effective-destination-repository mode))976 (dfile (qs* dest platform #t))977 (ddir (shell-variable "DESTDIR" platform)))978 (print "\n" mkdir " " ddir dfile)979 (print cmd " " out " " ddir980 (qs* (conc dest "/" types-file ".types") platform #t))981 (print-end-command platform)))982983(define ((install-inline-file name #!key mode inline-file)984 srcdir platform)985 (let* ((cmd (install-file-command platform))986 (mkdir (mkdir-command platform))987 (out (qs* (prefix srcdir (conc inline-file ".inline"))988 platform #t))989 (dest (effective-destination-repository mode))990 (dfile (qs* dest platform #t))991 (ddir (shell-variable "DESTDIR" platform)))992 (print "\n" mkdir " " ddir dfile)993 (print cmd " " out " " ddir994 (qs* (conc dest "/" inline-file ".inline") platform #t))995 (print-end-command platform)))996997(define ((install-program name #!key mode output-file) srcdir platform)998 (let* ((cmd (install-executable-command platform))999 (mkdir (mkdir-command platform))1000 (ext (executable-extension platform))1001 (sname (prefix srcdir name))1002 (out (qs* (target-file (conc sname ext) mode) platform #t))1003 (dest (if (eq? mode 'target)1004 default-bindir1005 (override-prefix "/bin" host-bindir)))1006 (dfile (qs* dest platform #t))1007 (ddir (shell-variable "DESTDIR" platform))1008 (destf (qs* (conc dest "/" output-file ext) platform #t)))1009 (print "\n" mkdir " " ddir dfile)1010 (print cmd " " out " " ddir destf)1011 (print-end-command platform)))10121013(define (install-random-files dest files mode srcdir platform)1014 (let* ((fcmd (install-file-command platform))1015 (dcmd (copy-directory-command platform))1016 (root (string-append srcdir "/"))1017 (mkdir (mkdir-command platform))1018 (sfiles (map (cut prefix srcdir <>) files))1019 (dfile (qs* dest platform #t))1020 (ddir (shell-variable "DESTDIR" platform)))1021 (print "\n" mkdir " " ddir dfile)1022 (let-values (((ds fs) (partition directory? sfiles)))1023 (for-each1024 (lambda (d)1025 (let* ((ds (strip-dir-prefix srcdir d))1026 (fdir (pathname-directory ds)))1027 (when fdir1028 (print mkdir " " ddir1029 (qs* (make-pathname dest fdir) platform #t)))1030 (print dcmd " " (qs* d platform #t)1031 " " ddir1032 (if fdir1033 (qs* (make-pathname dest fdir) platform #t)1034 dfile))1035 (print-end-command platform)))1036 ds)1037 (when (pair? fs)1038 (for-each1039 (lambda (f)1040 (let* ((fs (strip-dir-prefix srcdir f))1041 (fdir (pathname-directory fs)))1042 (when fdir1043 (print mkdir " " ddir1044 (qs* (make-pathname dest fdir) platform #t)))1045 (print fcmd " " (qs* f platform)1046 " " ddir1047 (if fdir1048 (qs* (make-pathname dest fdir) platform #t)1049 dfile)))1050 (print-end-command platform))1051 fs)))))10521053(define ((install-data name #!key files destination mode)1054 srcdir platform)1055 (install-random-files (or destination1056 (if (eq? mode 'target)1057 default-sharedir1058 (override-prefix "/share"1059 host-sharedir)))1060 files mode srcdir platform))10611062(define ((install-c-include name #!key deps files destination mode)1063 srcdir platform)1064 (install-random-files (or destination1065 (if (eq? mode 'target)1066 default-incdir1067 (override-prefix "/include"1068 host-incdir)))1069 files mode srcdir platform))10701071;; manage dependency-targets10721073(define (add-dependency-target target output)1074 (cond ((assq target dependency-targets) =>1075 (lambda (a)1076 (set-cdr! a output)))1077 (else (set! dependency-targets1078 (cons (cons target output) dependency-targets)))))10791080(define (get-dependency-targets targets)1081 (append-map1082 (lambda (t)1083 (cond ((assq t dependency-targets) => (lambda (a) (list (cdr a))))1084 (else '())))1085 targets))108610871088;;; Generate shell or batch commands from abstract build/install operations10891090(define (generate-shell-commands platform cmds dest srcdir prefix suffix keep)1091 (fluid-let ((keep-generated-files keep))1092 (with-output-to-file dest1093 (lambda ()1094 (prefix platform)1095 (print (cd-command platform) " " (qs* srcdir platform #t))1096 (for-each1097 (lambda (cmd) (cmd srcdir platform))1098 cmds)1099 (suffix platform)))))110011011102;;; affixes for build- and install-scripts11031104(define ((build-prefix mode name info) platform)1105 (case platform1106 ((unix)1107 (printf #<<EOF1108#!/bin/sh~%1109set -e1110PATH=~a:$PATH1111export CHICKEN_CC=~a1112export CHICKEN_CXX=~a1113export CHICKEN_CSC=~a1114export CHICKEN_CSI=~a11151116EOF1117 (qs* default-bindir platform) (qs* default-cc platform)1118 (qs* default-cxx platform) (qs* default-csc platform)1119 (qs* default-csi platform)))1120 ((windows)1121 (printf #<<EOF1122@echo off~%1123set "PATH=~a;%PATH%"1124set "CHICKEN_CC=~a"1125set "CHICKEN_CXX=~a"1126set "CHICKEN_CSC=~a"1127set "CHICKEN_CSI=~a"11281129EOF1130 default-bindir default-cc1131 default-cxx default-csc1132 default-csi))))11331134(define ((build-suffix mode name info) platform)1135 (case platform1136 ((unix)1137 (printf #<<EOF1138EOF1139 ))1140 ((windows)1141 (printf #<<EOF1142EOF1143 ))))11441145(define ((install-prefix mode name info) platform)1146 (case platform1147 ((unix)1148 (printf #<<EOF1149#!/bin/sh~%1150set -e11511152EOF1153 ))1154 ((windows)1155 (printf #<<EOF1156@echo off~%1157EOF1158 ))))11591160(define ((install-suffix mode name info) platform)1161 (let* ((infostr (with-output-to-string (cut pp info)))1162 (dcmd (remove-file-command platform))1163 (mkdir (mkdir-command platform))1164 (dir (destination-repository mode))1165 (qdir (qs* dir platform #t))1166 (dest (qs* (make-pathname dir name +egg-info-extension+)1167 platform #t))1168 (ddir (shell-variable "DESTDIR" platform)))1169 (case platform1170 ((unix)1171 (printf #<<EOF11721173~a ~a~a1174~a ~a~a1175cat >~a~a <<'ENDINFO'1176~aENDINFO~%1177EOF1178 mkdir ddir qdir1179 dcmd ddir dest1180 ddir dest infostr))1181 ((windows)1182 (printf #<<EOF11831184~a ~a~a1185copy /y nul ~a~a~%1186~a1187EOF1188 mkdir ddir qdir1189 ddir dest1190 (string-intersperse (map (lambda (line)1191 (ensure-line-limit1192 (format "echo ~a >>~a~a"1193 (caretize line)1194 (caretize ddir)1195 (caretize dest))1196 8191))1197 (string-split infostr "\n"))1198 "\n"))))))11991200;;; some utilities for mangling + quoting12011202;; The qs procedure quotes for mingw32 or other platforms. We1203;; "normalised" the platform to "windows" in chicken-install, so we1204;; have to undo that here again. It can also convert slashes to1205;; backslashes on Windows, which is necessary in many cases when1206;; running programs via "cmd".1207;;1208;; It also supports already-quoted arguments which can be taken as-is.1209(define (qs* arg platform #!optional slashify?)1210 (if (raw-arg? arg)1211 (raw-arg-value arg)1212 (let* ((arg (->string arg))1213 (path (if slashify? (slashify arg platform) arg)))1214 (qs path (if (eq? platform 'windows) 'mingw32 platform)))))12151216(define-record-type raw-arg1217 (raw-arg value)1218 raw-arg?1219 (value raw-arg-value))12201221(define (slashify str platform)1222 (if (eq? platform 'windows)1223 (list->string1224 (map (lambda (c) (if (char=? #\/ c) #\\ c)) (string->list str)))1225 str))12261227(define (prefix dir name)1228 (make-pathname dir (->string name)))12291230;; Workaround for obscure behaviour of "system" on Windows: If a1231;; string starts with double quotes, you _must_ wrap the whole string1232;; in an extra set of quotes to avoid the outer quotes being stripped.1233;; Don't ask.1234(define (system+ str platform)1235 (system (if (and (eq? platform 'windows)1236 (positive? (string-length str))1237 (char=? #\" (string-ref str 0)))1238 (string-append "\"" str "\"")1239 str)))12401241(define (target-file fname mode)1242 (if (eq? mode 'target) (string-append fname ".target") fname))12431244(define (joins strs platform)1245 (string-intersperse (map (cut qs* <> platform) strs) " "))12461247(define (filelist dir lst)1248 (map (cut prefix dir <>) lst))12491250(define (shell-variable var platform)1251 (case platform1252 ((unix) (string-append "\"${" var "}\""))1253 ((windows) (string-append "%" var "%"))))12541255(define (prepare-custom-command cmd platform)1256 (unless (eq? 'windows platform)1257 (print "chmod +x " (qs* cmd platform))))12581259(define (custom-cmd custom srcdir platform)1260 (and custom (prefix srcdir1261 (case platform1262 ((windows) (conc custom ".bat"))1263 (else custom)))))12641265(define (print-build-command targets sources command-and-args platform)1266 (print "\n" (qs* default-builder platform) " "1267 (joins targets platform)1268 " : " (joins sources platform) " "1269 " : " (joins command-and-args platform)))12701271(define (print-end-command platform)1272 (case platform1273 ((windows) (print "if errorlevel 1 exit /b 1"))))12741275(define (strip-dir-prefix prefix fname)1276 (let* ((plen (string-length prefix))1277 (p1 (substring fname 0 plen)))1278 (assert (string=? prefix p1) "wrong prefix")1279 (substring fname (add1 plen))))12801281(define (maybe f x) (if f (list x) '()))12821283(define (caretize str)1284 (string-translate* str '(("&" . "^&") ("^" . "^^") ("|" . "^|")1285 ("<" . "^<") (">" . "^>"))))12861287(define (ensure-line-limit str lim)1288 (when (>= (string-length str) lim)1289 (error "line length exceeds platform limit: " str))1290 str)