~ chicken-core (master) /csc.scm
Trap1;;;; csc.scm - Driver program for the CHICKEN compiler - felix -*- Scheme -*-2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(module main ()2930(import scheme31 chicken.base32 chicken.file33 chicken.fixnum34 chicken.foreign35 chicken.format36 chicken.io37 chicken.pathname38 chicken.platform39 chicken.process40 chicken.process-context41 chicken.irregex42 chicken.string)4344(include "egg-environment.scm")45(include "mini-srfi-1.scm")4647(define-foreign-variable windows-shell bool "C_WINDOWS_SHELL")48(define-foreign-variable POSTINSTALL_PROGRAM c-string "C_INSTALL_POSTINSTALL_PROGRAM")49(define-foreign-variable INSTALL_LIB_NAME c-string "C_INSTALL_LIB_NAME")50(define-foreign-variable TARGET_LIB_NAME c-string "C_TARGET_LIB_NAME")51(define host-libs (string-split (foreign-value "C_INSTALL_MORE_LIBS" c-string)))52(define-foreign-variable TARGET_MORE_STATIC_LIBS c-string "C_TARGET_MORE_STATIC_LIBS")53(define-foreign-variable INSTALL_MORE_STATIC_LIBS c-string "C_INSTALL_MORE_STATIC_LIBS")54(define TARGET_CC default-cc)55(define-foreign-variable CHICKEN_PROGRAM c-string "C_CHICKEN_PROGRAM")56(define-foreign-variable TARGET_FEATURES c-string "C_TARGET_FEATURES")57(define-foreign-variable TARGET_RUN_LIB_HOME c-string "C_TARGET_RUN_LIB_HOME")58(define-foreign-variable TARGET_RC_COMPILER c-string "C_TARGET_RC_COMPILER")59(define-foreign-variable INSTALL_RC_COMPILER c-string "C_INSTALL_RC_COMPILER")60(define-foreign-variable TARGET_LDFLAGS c-string "C_TARGET_LDFLAGS")61(define-foreign-variable INSTALL_LDFLAGS c-string "C_INSTALL_LDFLAGS")62(define-foreign-variable CSC_PROGRAM c-string "C_CSC_PROGRAM")636465;;; Parameters:6667(define windows (eq? (software-type) 'windows))68(define mingw (eq? (software-version) 'mingw))69(define osx (eq? (software-version) 'macosx))70(define cygwin (eq? (software-version) 'cygwin))71(define aix (eq? (build-platform) 'aix))72(define solaris (memq (software-version) '(solaris sunos)))7374(define elf75 (memq (software-version) '(linux netbsd freebsd solaris openbsd hurd haiku)))7677(define (stop msg . args)78 (fprintf (current-error-port) "~a: ~?~%" CSC_PROGRAM msg args)79 (exit 64) )8081(define arguments (command-line-arguments))82(define cross-chicken (feature? #:cross-chicken))83(define host-mode (or (not cross-chicken) (member "-host" arguments)))8485(define (back-slash->forward-slash path)86 (if windows-shell87 (string-translate path #\\ #\/)88 path))8990(define (quotewrap str)91 (qs (back-slash->forward-slash (normalize-pathname str))))9293(define home94 (if host-mode host-sharedir default-sharedir))9596(define translator97 (make-pathname host-bindir CHICKEN_PROGRAM))9899(define compiler (if host-mode host-cc default-cc))100(define c++-compiler (if host-mode host-cxx default-cxx))101(define rc-compiler (if host-mode INSTALL_RC_COMPILER TARGET_RC_COMPILER))102(define linker (if host-mode host-cc default-cc))103(define c++-linker (if host-mode host-cxx default-cxx))104(define object-extension "o")105(define library-extension "a")106(define link-output-flag "-o")107(define executable-extension "")108(define compile-output-flag "-o")109(define shared-library-extension ##sys#load-dynamic-extension)110(define static-object-extension (##sys#string-append "static." object-extension))111(define static-library-extension (##sys#string-append "static." library-extension))112(define default-translation-optimization-options '())113(define pic-options (if (or mingw cygwin) '("-DPIC") '("-fPIC" "-DPIC")))114(define generate-manifest #f)115116(define (libchicken)117 (string-append "lib"118 (if (not host-mode)119 TARGET_LIB_NAME120 INSTALL_LIB_NAME)))121122(define (dynamic-libchicken)123 (if cygwin124 (string-append "cyg" INSTALL_LIB_NAME "-0") ; XXX not target125 (libchicken)))126127(define (default-library)128 (make-pathname library-dir (string-append (libchicken) "-static") library-extension))129130(define default-compilation-optimization-options131 (string-split (if host-mode host-cflags default-cflags)))132133(define best-compilation-optimization-options134 default-compilation-optimization-options)135136(define default-linking-optimization-options137 (string-split (if host-mode INSTALL_LDFLAGS TARGET_LDFLAGS)))138139(define best-linking-optimization-options140 default-linking-optimization-options)141142(define extra-features (if host-mode '() (string-split TARGET_FEATURES)))143144(define-constant simple-options145 '(-explicit-use -no-trace -no-warnings -no-usual-integrations -optimize-leaf-routines -unsafe146 -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile147 -check-syntax -case-insensitive -shared -compile-syntax -no-lambda-info148 -dynamic -disable-stack-overflow-checks -local149 -emit-external-prototypes-first -inline -release150 -analyze-only -keep-shadowed-macros -inline-global -ignore-repository151 -no-parentheses-synonyms -r7rs-syntax152 -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax153 -emit-all-import-libraries -no-elevation -module-registration -no-module-registration154 -no-procedure-checks-for-usual-bindings -regenerate-import-libraries155 -specialize -strict-types -lfa2 -debug-info -merge-reusable-closures156 -merge-shareable-closures157 -no-procedure-checks-for-toplevel-bindings))158159(define-constant complex-options160 '(-debug -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style161 -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue -emit-link-file162 -inline-limit -profile-name -unroll-limit163 -emit-inline-file -consult-inline-file164 -emit-types-file -consult-types-file165 -feature -debug-level166 -emit-import-library167 -module -link168 -no-feature))169170(define-constant shortcuts171 '((-h "-help")172 (-s "-shared")173 (-m "-module")174 (|-P| "-check-syntax")175 (-f "-fixnum-arithmetic")176 (|-D| "-feature")177 (-i "-case-insensitive")178 (|-K| "-keyword-style")179 (|-X| "-extend")180 (|-J| "-emit-all-import-libraries")181 (|-M| "-module-registration")182 (|-N| "-no-module-registration")183 (-x "-explicit-use")184 (-u "-unsafe")185 (-j "-emit-import-library")186 (-b "-block")187 (-types "-consult-types-file")))188189;; TODO is this up-to-date?190(define short-options191 (string->list "PHhsfiENxubvwAOeWkctgSJM") )192193194;;; Variables:195196(define scheme-files '())197(define c-files '())198(define rc-files '())199(define generated-c-files '())200(define generated-rc-files '())201(define object-files '())202(define generated-object-files '())203(define transient-link-files '())204(define linked-extensions '())205(define cpp-mode #f)206(define objc-mode #f)207(define embedded #f)208(define inquiry-only #f)209(define show-cflags #f)210(define show-ldflags #f)211(define show-libs #f)212(define dry-run #f)213(define gui #f)214(define deployed #f)215(define rpath #f)216(define ignore-repository #f)217(define show-debugging-help #f)218219(define library-dir220 (if host-mode host-libdir default-libdir))221222(define extra-libraries223 (string-split (if host-mode224 INSTALL_MORE_STATIC_LIBS225 TARGET_MORE_STATIC_LIBS)))226227(define extra-shared-libraries228 (if host-mode host-libs default-libs))229230(define (library-files)231 (list (default-library)))232233(define (shared-library-files)234 (list (string-append "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME))))235236(define translate-options '())237238(define include-dir239 (let ((id (if host-mode host-incdir default-incdir)))240 (and (not (member id '("/usr/include" "")))241 id) ) )242243(define compile-options '())244245(define builtin-compile-options246 (append247 (if include-dir (list (conc "-I" include-dir)) '())248 (cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>249 (lambda (path)250 (map (cut string-append "-I" <>) (string-split path ":;"))))251 (else '()))))252253(define compile-only-flag "-c")254(define translation-optimization-options default-translation-optimization-options)255(define compilation-optimization-options default-compilation-optimization-options)256(define linking-optimization-options default-linking-optimization-options)257258(define link-options '())259(define rpath-option (if solaris "-R" "-rpath="))260261(define (builtin-link-options)262 (append263 (cond (elf264 (list265 (conc "-L" library-dir)266 (conc "-Wl," rpath-option267 (if deployed268 "$ORIGIN"269 (if host-mode270 host-libdir271 TARGET_RUN_LIB_HOME)))))272 (aix273 (list (conc "-Wl," rpath-option library-dir)))274 (else275 (list (conc "-L" library-dir))))276 (if (and deployed (memq (software-version) '(freebsd openbsd netbsd)))277 (list "-Wl,-z,origin")278 '())279 (cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>280 (lambda (path)281 (map (cut string-append "-L" <>) (string-split path ":;"))))282 (else '()))))283284(define target-filename #f)285(define verbose #f)286(define keep-files #f)287(define translate-only #f)288(define compile-only #f)289(define to-stdout #f)290(define shared #f)291(define static #f)292293294;;; Locate object files for linking:295296(define (repo-path)297 (if host-mode298 (repository-path)299 (destination-repository 'target)))300301(define (find-object-file name)302 (let ((o (make-pathname #f name object-extension))303 (a (make-pathname #f name library-extension))304 ;; objects in build dir may also end with "static.o"305 (static-a (make-pathname #f name static-library-extension))306 (static-o (make-pathname #f name static-object-extension)))307 (or (file-exists? a)308 (file-exists? o)309 (cond-expand310 (windows (file-exists? (make-pathname #f name "obj")))311 (else #f))312 (file-exists? static-a)313 (file-exists? static-o)314 (cond-expand315 (windows316 (file-exists? (make-pathname #f name "static.obj")))317 (else #f))318 (and (not ignore-repository)319 (or (chicken.load#find-file a (repo-path))320 (chicken.load#find-file o (repo-path)))))))321322323;;; Display usage information:324325(define (usage)326 (let ((csc CSC_PROGRAM))327 (print #<#EOF328Usage: #{csc} [OPTION ...] [FILENAME ...]329330 `#{csc}' is a driver program for the CHICKEN compiler. Files given on the331 command line are translated, compiled or linked as needed.332333 FILENAME is a Scheme source file name with optional extension or a334 C/C++/Objective-C source, object or library file name with extension. OPTION335 may be one of the following:336337 General options:338339 -h -help display this text and exit340 -v -verbose show compiler notes and tool-invocations341 -vv display information about all compilation342 stages343 -version display Scheme compiler version and exit344 -release display release number and exit345346 File and pathname options:347348 -o -output-file FILENAME specifies target executable name349 -I -include-path PATHNAME specifies alternative path for included350 files351 -to-stdout write compiler to stdout (implies -t)352 -s -shared -dynamic generate dynamically loadable shared object353 file354355 Language options:356357 -D -DSYMBOL -feature SYMBOL register feature identifier358 -no-feature SYMBOL disable builtin feature identifier359 -c++ compile via a C++ source file (.cpp)360 -objc compile via Objective-C source file (.m)361362 Syntax related options:363364 -i -case-insensitive don't preserve case of read symbols365 -K -keyword-style STYLE enable alternative keyword-syntax366 (prefix, suffix or none)367 -no-parentheses-synonyms disables list delimiter synonyms368 -no-symbol-escape disables support for escaped symbols369 -r7rs-syntax disables the CHICKEN extensions to370 R7RS syntax371 -compile-syntax macros are made available at run-time372 -j -emit-import-library MODULE write compile-time module information into373 separate file374 -J -emit-all-import-libraries emit import-libraries for all defined modules375 -no-compiler-syntax disable expansion of compiler-macros376 -m -module NAME wrap compiled code in a module377 -M -module-registration always generate module registration code378 -N -no-module-registration never generate module registration code379 (overrides `-M')380381 Translation options:382383 -x -explicit-use do not use units `library' and `eval' by384 default385 -P -check-syntax stop compilation after macro-expansion386 -A -analyze-only stop compilation after first analysis pass387388 Debugging options:389390 -w -no-warnings disable warnings391 -d0 -d1 -d2 -d3 -debug-level NUMBER392 set level of available debugging information393 -no-trace disable rudimentary debugging information394 -debug-info enable debug-information in compiled code for use395 with an external debugger396 -profile executable emits profiling information397 -accumulate-profile executable emits profiling information in398 append mode399 -profile-name FILENAME name of the generated profile information400 file401 -consult-types-file FILENAME load additional type database402403 Optimization options:404405 -O -O0 -O1 -O2 -O3 -O4 -O5 -optimize-level NUMBER406 enable certain sets of optimization options407 -optimize-leaf-routines enable leaf routine optimization408 -no-usual-integrations standard procedures may be redefined409 -u -unsafe disable safety checks410 -local assume globals are only modified in current411 file412 -b -block enable block-compilation413 -disable-interrupts disable interrupts in compiled code414 -f -fixnum-arithmetic assume all numbers are fixnums415 -disable-stack-overflow-checks disables detection of stack-overflows416 -inline enable inlining417 -inline-limit LIMIT set inlining threshold418 -inline-global enable cross-module inlining419 -specialize perform type-based specialization of primitive calls420 -oi -emit-inline-file FILENAME generate file with globally inlinable421 procedures (implies -inline -local)422 -consult-inline-file FILENAME explicitly load inline file423 -ot -emit-types-file FILENAME write type-declaration information into file424 -no-argc-checks disable argument count checks425 -no-bound-checks disable bound variable checks426 -no-procedure-checks disable procedure call checks427 -no-procedure-checks-for-usual-bindings428 disable procedure call checks only for usual429 bindings430 -no-procedure-checks-for-toplevel-bindings431 disable procedure call checks for toplevel432 bindings433 -strict-types assume variable do not change their type434 -lfa2 perform additional lightweight flow-analysis pass435 -unroll-limit LIMIT specifies inlining limit for self-recursive calls436 -merge-reusable-closures enables closure reuse437 -merge-shareable-closures enables closure sharing438439 Configuration options:440441 -unit NAME compile file as a library unit442 -uses NAME declare library unit as used.443 -heap-size NUMBER specifies heap-size of compiled executable444 -nursery NUMBER -stack-size NUMBER445 specifies nursery size of compiled446 executable447 -X -extend FILENAME load file before compilation commences448 -prelude EXPRESSION add expression to beginning of source file449 -postlude EXPRESSION add expression to end of source file450 -prologue FILENAME include file before main source file451 -epilogue FILENAME include file after main source file452453 -e -embedded compile as embedded454 (don't generate `main()')455 -gui compile as GUI application456 -link NAME link extension with compiled executable457 (implies -uses)458 -R -require-extension NAME require extension and import in compiled459 code460 -dll -library compile multiple units into a dynamic461 library462 -libdir DIRECTORY override directory for runtime library463464 Options to other passes:465466 -C OPTION pass option to C compiler467 -L OPTION pass option to linker468 -I<DIR> pass \"-I<DIR>\" to C compiler469 (add include path)470 -L<DIR> pass \"-L<DIR>\" to linker471 (add library path)472 -k keep intermediate files473 -c stop after compilation to object files474 -t stop after translation to C475 -cc COMPILER select other C compiler than the default476 -cxx COMPILER select other C++ compiler than the default477 -ld COMPILER select other linker than the default478 -static link with static CHICKEN libraries and479 extensions (if possible)480 -F<DIR> pass \"-F<DIR>\" to C compiler481 (add framework header path on Mac OS X)482 -framework NAME passed to linker on Mac OS X483 -rpath PATHNAME add directory to runtime library search path484 -Wl,... pass linker options485 -strip strip resulting binary486487 Inquiry options:488489 -home show home-directory (where support files go)490 -cflags show required C-compiler flags and exit491 -ldflags show required linker flags and exit492 -libs show required libraries and exit493 -cc-name show name of default C compiler used494 -cxx-name show name of default C++ compiler used495 -ld-name show name of default linker used496 -dry-run just show commands executed, don't run them497 (implies `-v')498499 Obscure options:500501 -debug MODES display debugging output for the given modes502 -compiler PATHNAME use other compiler than default `chicken'503 -raw do not generate implicit init- and exit code504 -emit-external-prototypes-first505 emit prototypes for callbacks before foreign506 declarations507 -regenerate-import-libraries emit import libraries even when unchanged508 -ignore-repository do not refer to repository for extensions509 -keep-shadowed-macros do not remove shadowed macro510 -host compile for host when configured for511 cross-compiling512 -private-repository load extensions from executable path513 -deployed link support file to be used from a deployed514 executable (sets `rpath' accordingly, if supported515 on this platform)516 -no-elevation embed manifest on Windows to supress elevation517 warnings for programs named `install' or `setup'518519 Options can be collapsed if unambiguous, so520521 -vkfO522523 is the same as524525 -v -k -fixnum-arithmetic -optimize526527 The contents of the environment variable CSC_OPTIONS are implicitly passed to528 every invocation of `#{csc}'.529530EOF531;| (for emacs font-lock)532 ) ) )533534535;;; Parse arguments:536537(define (run args)538539 (define (t-options . os)540 (set! translate-options (append translate-options os)) )541542 (define (check o r . n)543 (unless (>= (length r) (optional n 1))544 (stop "not enough arguments to option `~A'" o) ) )545546 (define (shared-build lib)547 (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))548 (set! compile-options (append pic-options '("-DC_SHARED") compile-options))549 (set! link-options550 (append551 (cond552 (osx (if lib '("-dynamiclib") '("-bundle" "-headerpad_max_install_names")))553 (else '("-shared"))) link-options))554 (set! shared #t) )555556 (define (use-private-repository)557 (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))558559 (define (generate-target-filename source-filename)560 (pathname-replace-extension561 source-filename562 (cond (shared shared-library-extension)563 (compile-only object-extension)564 (else executable-extension))))565566 (let loop ((args args))567 (cond [(null? args)568 ;; Builtin search directory options do not override explicit options569 (set! compile-options (append compile-options builtin-compile-options))570 (set! link-options (append link-options (builtin-link-options)))571 ;;572 (when inquiry-only573 (when show-cflags (for-each (cut print* <> #\space) (compiler-options)))574 (when show-ldflags (for-each (cut print* <> #\space) (linker-options)))575 (when show-libs (for-each (cut print* <> #\space) (linker-libraries)))576 (newline)577 (exit) )578 (when (and compile-only579 (> (+ (length scheme-files)580 (length c-files))581 1))582 (stop "the `-c' option cannot be used in combination with multiple input files"))583 (cond ((null? scheme-files)584 (when (and (null? c-files)585 (null? object-files))586 (when show-debugging-help587 (exec translator (cons "bogus.scm" translate-options)))588 (stop "no source files specified") )589 (unless target-filename590 (set! target-filename591 (generate-target-filename592 (last (if (null? c-files) object-files c-files))))))593 (else594 (when (and shared (not embedded))595 (set! translate-options (cons "-dynamic" translate-options)) )596 (unless target-filename597 (set! target-filename598 (generate-target-filename (first scheme-files))))599 (run-translation)))600 (unless translate-only601 (run-compilation)602 (unless compile-only603 (when (pair? linked-extensions)604 (set! object-files ; add objects from linked extensions605 (append (filter-map find-object-file linked-extensions) object-files)))606 (when (member target-filename scheme-files)607 (fprintf (current-error-port)608 "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"609 target-filename target-filename)610 (exec (if windows-shell "move" "mv")611 (list target-filename612 (string-append target-filename ".old"))))613 (run-linking)) ) ]614 [else615 (let* ([arg (car args)]616 [rest (cdr args)]617 [s (string->symbol arg)] )618 (case s619 [(-help --help)620 (usage)621 (exit) ]622 [(-release)623 (print (chicken-version))624 (exit) ]625 [(-version)626 (exec translator '("-version"))627 (exit)]628 [(-c++)629 (set! cpp-mode #t)630 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]631 [(-objc)632 (set! objc-mode #t) ]633 [(-static)634 (set! translate-options (cons "-static" translate-options))635 (set! static #t)]636 [(-cflags)637 (set! inquiry-only #t)638 (set! show-cflags #t) ]639 [(-ldflags)640 (set! inquiry-only #t)641 (set! show-ldflags #t) ]642 [(-cc-name) (print compiler) (exit 0)]643 [(-cxx-name) (print c++-compiler) (exit 0)]644 [(-ld-name) (print linker) (exit 0)]645 [(-home) (print home) (exit 0)]646 [(-libs)647 (set! inquiry-only #t)648 (set! show-libs #t) ]649 ((-v -verbose)650 (when (number? verbose)651 (set! compile-options (cons* "-v" "-Q" compile-options))652 (set! link-options (cons "-v" link-options)) )653 (t-options "-verbose")654 (if verbose655 (set! verbose 2)656 (set! verbose #t)) )657 [(-w -no-warnings)658 (set! compile-options (cons "-w" compile-options))659 (t-options "-no-warnings") ]660 [(|-A| -analyze-only)661 (set! translate-only #t)662 (t-options "-analyze-only") ]663 [(|-P| -check-syntax)664 (set! translate-only #t)665 (t-options "-check-syntax") ]666 [(-k) (set! keep-files #t)]667 [(-c) (set! compile-only #t)]668 [(-t) (set! translate-only #t)]669 [(-e -embedded)670 (set! embedded #t)671 (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]672 [(-link)673 (check s rest)674 (t-options "-link" (car rest))675 (set! linked-extensions676 (append linked-extensions (string-split (car rest) ", ")))677 (set! rest (cdr rest))]678 ((-libdir)679 (check s rest)680 (set! library-dir (car rest))681 (set! rest (cdr rest)))682 [(-require-extension -R)683 (check s rest)684 (t-options "-require-extension" (car rest))685 (set! rest (cdr rest)) ]686 ((-private-repository)687 (use-private-repository))688 ((-ignore-repository)689 (set! ignore-repository #t)690 (t-options arg))691 ((-setup-mode)692 (set! ##sys#setup-mode #t)693 (t-options arg))694 ((-no-elevation)695 (set! generate-manifest #t))696 [(-gui)697 (set! gui #t)698 (set! compile-options (cons "-DC_GUI" compile-options))699 (when mingw700 (set! object-files701 (cons (make-pathname702 host-sharedir "chicken.rc"703 object-extension)704 object-files))705 (set! link-options706 (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"707 link-options)))]708 ((-deployed)709 (set! deployed #t))710 [(-framework)711 (check s rest)712 (when osx713 (set! link-options (cons* "-framework" (car rest) link-options)) )714 (set! rest (cdr rest)) ]715 [(-o -output-file)716 (check s rest)717 (let ([fn (car rest)])718 (set! rest (cdr rest))719 (set! target-filename fn) ) ]720 [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]721 [(|-O0|) (set! rest (cons* "-optimize-level" "0" rest))]722 [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]723 [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]724 [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]725 [(|-O5|)726 (set! rest (cons* "-optimize-level" "5" rest))]727 [(|-d0|) (set! rest (cons* "-debug-level" "0" rest))]728 [(|-d1|) (set! rest (cons* "-debug-level" "1" rest))]729 [(|-d2|) (set! rest (cons* "-debug-level" "2" rest))]730 [(|-d3|) (set! rest (cons* "-debug-level" "3" rest))]731 ((-debug)732 (check s rest)733 (t-options arg (car rest))734 (when (memv #\h (string->list (car rest)))735 (set! show-debugging-help #t)736 (set! translate-only #t))737 (set! rest (cdr rest)))738 [(-dry-run)739 (set! verbose #t)740 (set! dry-run #t)]741 [(-s -shared -dynamic)742 (shared-build #f) ]743 [(-dll -library)744 (shared-build #t) ]745 [(-compiler)746 (check s rest)747 (set! translator (car rest))748 (set! rest (cdr rest)) ]749 [(-cc)750 (check s rest)751 (set! compiler (car rest))752 (set! rest (cdr rest)) ]753 [(-cxx)754 (check s rest)755 (set! c++-compiler (car rest))756 (set! rest (cdr rest)) ]757 [(-ld)758 (check s rest)759 (set! linker (car rest))760 (set! rest (cdr rest)) ]761 [(|-I|)762 (check s rest)763 (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]764 [(|-C|)765 (check s rest)766 (set! compile-options (append compile-options (string-split (car rest))))767 (set! rest (cdr rest)) ]768 [(-strip)769 (set! link-options (append link-options (list "-s")))]770 [(|-L|)771 (check s rest)772 (set! link-options (append link-options (string-split (car rest))))773 (set! rest (cdr rest)) ]774 [(-rpath)775 (check s rest)776 (set! rpath (car rest))777 (when (and (memq (build-platform) '(gnu clang))778 (not mingw) (not osx))779 (set! link-options780 (append link-options (list (string-append "-Wl," rpath-option rpath)))) )781 (set! rest (cdr rest)) ]782 [(-host) #f]783 ((-oi)784 (check s rest)785 (t-options "-emit-inline-file" (car rest))786 (set! rest (cdr rest)))787 ((-ot)788 (check s rest)789 (t-options "-emit-types-file" (car rest))790 (set! rest (cdr rest)))791 [(-)792 (set! scheme-files (append scheme-files '("-")))793 (unless target-filename794 (set! target-filename (make-pathname #f "a" executable-extension)))]795 [else796 (when (eq? s '-to-stdout)797 (set! to-stdout #t)798 (set! translate-only #t) )799 (when (memq s '(-optimize-level -benchmark-mode))800 (set! compilation-optimization-options best-compilation-optimization-options)801 (set! linking-optimization-options best-linking-optimization-options) )802 (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]803 [(memq s simple-options) (t-options arg)]804 ((memq s complex-options)805 (check s rest)806 (t-options arg (car rest))807 (set! rest (cdr rest)))808 [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))809 (t-options arg) ]810 [(and (> (string-length arg) 1)811 (char=? #\- (string-ref arg 0)) )812 (cond [(char=? #\L (string-ref arg 1))813 (when (char-whitespace? (string-ref arg 2))814 (error "bad -L argument, <DIR> starts with whitespace" arg))815 (set! link-options (append link-options (list arg))) ]816 [(char=? #\I (string-ref arg 1))817 (when (char-whitespace? (string-ref arg 2))818 (error "bad -I argument: <DIR> starts with whitespace" arg))819 (set! compile-options (append compile-options (list arg))) ]820 [(char=? #\D (string-ref arg 1))821 (t-options "-feature" (substring arg 2)) ]822 [(char=? #\F (string-ref arg 1))823 (when osx824 (set! compile-options (append compile-options (list arg))) ) ]825 [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))826 (set! link-options (append link-options (list arg))) ]827 [(> (string-length arg) 2)828 (let ([opts (cdr (string->list arg))])829 (cond ((null? (lset-difference/eq? opts short-options))830 (set! rest831 (append (map (lambda (o)832 (string-append "-" (string o))) opts)833 rest) ))834 ((char=? #\l (car opts))835 (stop "invalid option `~A' - did you mean `-L -l<library>'?" arg))836 (else (stop "invalid option `~A'" arg) ) )) ]837 [else (stop "invalid option `~A'" s)] ) ]838 [(file-exists? arg)839 (let-values ([(dirs name ext) (decompose-pathname arg)])840 (cond [(not ext)841 (set! scheme-files (append scheme-files (list arg)))]842 [(member ext '("h" "c"))843 (set! c-files (append c-files (list arg))) ]844 ((string-ci=? ext "rc")845 (set! rc-files (append rc-files (list arg))) )846 [(member ext '("cpp" "C" "cc" "cxx" "hpp"))847 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))848 (set! cpp-mode #t)849 (set! c-files (append c-files (list arg))) ]850 [(member ext '("m" "M" "mm"))851 (set! objc-mode #t)852 (set! c-files (append c-files (list arg))) ]853 [(or (string=? ext object-extension)854 (string=? ext library-extension) )855 (set! object-files (append object-files (list arg))) ]856 [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]857 [else858 (let ([f2 (string-append arg ".scm")])859 (if (file-exists? f2)860 (set! rest (cons f2 rest))861 (stop "file `~A' does not exist" arg) ) ) ] ) ] )862 (loop rest) ) ] ) ) )863864865;;; Translate all Scheme files:866867(define (run-translation)868 (for-each869 (lambda (f)870 (let* ((sf (if (= 1 (length scheme-files))871 target-filename872 f))873 (fc (pathname-replace-extension874 sf875 (cond (cpp-mode "cpp")876 (objc-mode "m")877 (else "c") ) ) ) )878 (when (member fc c-files)879 (stop "C file generated from `~a' will overwrite explicitly given source file `~a'"880 f fc))881 (exec882 translator883 (cons* f884 (append885 (if to-stdout886 '("-to-stdout")887 `("-output-file" ,fc) )888 (if (##sys#debug-mode?)889 '("-:d")890 '())891 extra-features892 translate-options893 (if (and static894 (not (member "-emit-link-file"895 translate-options)))896 (list "-emit-link-file"897 (pathname-replace-extension fc "link"))898 '())899 (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))900 (objc-mode '("-feature" "chicken-scheme-to-objc"))901 (else '()))902 translation-optimization-options ) ) )903 (when (and static compile-only)904 (set! transient-link-files905 (cons (pathname-replace-extension f "link")906 transient-link-files)))907 (set! c-files (append (list fc) c-files))908 (set! generated-c-files (append (list fc) generated-c-files))))909 scheme-files))910911912;;; Compile all C/C++ and .rc files:913914(define (run-compilation)915 (let ((ofiles '()))916 (for-each917 (lambda (f)918 (let ((fo (if (and compile-only919 target-filename920 (= 1 (length c-files)))921 target-filename922 (pathname-replace-extension f object-extension))))923 (when (member fo object-files)924 (stop "object file generated from `~a' will overwrite explicitly given object file `~a'"925 f fo))926 (exec (cond (cpp-mode c++-compiler)927 (else compiler) )928 (cons* f929 compile-output-flag fo930 compile-only-flag931 (append (if (and cpp-mode (string=? "g++" c++-compiler)) ; XXX This is somewhat hacky - g++ might not be *named* g++932 '("-Wno-write-strings")933 '())934 (compiler-options)) ) )935 (set! generated-object-files (cons fo generated-object-files))936 (set! ofiles (cons fo ofiles))))937 c-files)938 (when (and generate-manifest (eq? 'windows (software-type)))939 (let ((rcf (pathname-replace-extension target-filename "rc")))940 (create-win-manifest (pathname-file target-filename) rcf)941 (set! rc-files (cons rcf rc-files))942 (set! generated-rc-files (cons rcf generated-rc-files))))943 (for-each944 (lambda (f)945 (let ((fo (string-append f "." object-extension)))946 (exec rc-compiler (list f fo))947 (set! generated-object-files (cons fo generated-object-files))948 (set! ofiles (cons fo ofiles))))949 rc-files)950 (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first951 (unless keep-files952 (for-each $delete-file generated-c-files)953 (for-each $delete-file generated-rc-files))))954955(define (compiler-options)956 (append957 compilation-optimization-options958 compile-options) )959960961;;; Link object files and libraries:962963(define (run-linking)964 (set! object-files965 (collect-linked-objects object-files generated-object-files))966 (exec (cond (cpp-mode c++-linker)967 (else linker) )968 (append969 object-files970 (list link-output-flag target-filename)971 (linker-options)972 (linker-libraries) ) )973 (when (and osx host-mode)974 (let ((lib (string-append (libchicken) ".dylib")))975 (exec POSTINSTALL_PROGRAM976 (list "-change" lib977 (if deployed978 (make-pathname "@executable_path" lib)979 (make-pathname (or rpath980 (if host-mode981 host-libdir982 TARGET_RUN_LIB_HOME))983 lib))984 target-filename))))985 (unless keep-files986 (for-each $delete-file987 (append generated-object-files988 transient-link-files))))989990(define (collect-linked-objects ofiles gen-ofiles)991 (define (locate-link-file o)992 (let* ((p (pathname-strip-extension o))993 ;; Also strip "static.o" extension when needed:994 (f (string-chomp p ".static")))995 (file-exists? (make-pathname #f f "link"))))996 (define (locate-objects libs)997 (map (lambda (id)998 (or (find-object-file id)999 (stop "could not find linked extension: ~A" id)))1000 (map ->string libs)))1001 (let loop ((os ofiles) (os2 ofiles))1002 (cond ((null? os)1003 (delete-duplicates (reverse os2) string=?))1004 ((or static (not (member (car os) gen-ofiles)))1005 (let* ((lfile (locate-link-file (car os)))1006 (newos (if lfile1007 (locate-objects (with-input-from-file lfile read))1008 '())))1009 (loop (append newos (cdr os)) (append newos os2))))1010 (else (loop (cdr os) (cons (car os) os2))))))10111012(define (copy-files from to)1013 (exec (if windows-shell "copy" "cp")1014 (append (if windows-shell '("/Y") '())1015 (list from to))))10161017(define (linker-options)1018 (append linking-optimization-options link-options) )10191020(define (linker-libraries)1021 (append1022 (if static1023 (library-files)1024 (shared-library-files))1025 (if static1026 extra-libraries1027 extra-shared-libraries)))102810291030;;; Helper procedures:10311032;; Simpler replacement for SRFI-13's string-any1033(define (string-any criteria s)1034 (let ((end (string-length s)))1035 (let lp ((i 0))1036 (let ((c (string-ref s i))1037 (i1 (+ i 1)))1038 (if (= i1 end) (criteria c)1039 (or (criteria c)1040 (lp i1)))))))10411042(define (exec prog args)1043 ;; NOTE: We construct a command line for debugging purposes, but it1044 ;; does not 100% represent what gets executed.1045 (let ((cmdline (string-intersperse (map quotewrap (cons prog args)) " ")))1046 (when verbose1047 (print cmdline))1048 (unless dry-run1049 (let*-values (((pid) (process-run prog args))1050 ((pid success? exit-code) (process-wait pid)))1051 (when (or (not success?) (not (zero? exit-code)))1052 (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" exit-code cmdline)1053 (exit exit-code))))))10541055(define ($delete-file str)1056 (when verbose1057 (print "rm " str) )1058 (unless dry-run (delete-file str) ))10591060(define (create-win-manifest prg rcfname)1061 (when verbose (print "generating " rcfname))1062 (with-output-to-file rcfname1063 (lambda ()1064 (print #<#EOF10651 24 MOVEABLE PURE1066BEGIN1067 "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>\r\n"1068 "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">\r\n"1069 " <assemblyIdentity version=""1.0.0.0"" processorArchitecture=""*"" name=""#{prg}"" type=""win32""/>\r\n"1070 " <ms_asmv2:trustInfo xmlns:ms_asmv2=""urn:schemas-microsoft-com:asm.v2"">\r\n"1071 " <ms_asmv2:security>\r\n"1072 " <ms_asmv2:requestedPrivileges>\r\n"1073 " <ms_asmv2:requestedExecutionLevel level=""asInvoker"" uiAccess=""false""/>\r\n"1074 " </ms_asmv2:requestedPrivileges>\r\n"1075 " </ms_asmv2:security>\r\n"1076 " </ms_asmv2:trustInfo>\r\n"1077 "</assembly>\r\n"1078END1079EOF1080) ) ) )108110821083;;; Run it:10841085(run1086 (append1087 (string-split (or (get-environment-variable "CSC_OPTIONS") ""))1088 arguments))10891090)