~ 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 (if mingw "obj" "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-info156 -no-procedure-checks-for-toplevel-bindings))157158(define-constant complex-options159 '(-debug -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style160 -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue -emit-link-file161 -inline-limit -profile-name -unroll-limit162 -emit-inline-file -consult-inline-file163 -emit-types-file -consult-types-file164 -feature -debug-level165 -emit-import-library166 -module -link167 -no-feature))168169(define-constant shortcuts170 '((-h "-help")171 (-s "-shared")172 (-m "-module")173 (|-P| "-check-syntax")174 (-f "-fixnum-arithmetic")175 (|-D| "-feature")176 (-i "-case-insensitive")177 (|-K| "-keyword-style")178 (|-X| "-extend")179 (|-J| "-emit-all-import-libraries")180 (|-M| "-module-registration")181 (|-N| "-no-module-registration")182 (-x "-explicit-use")183 (-u "-unsafe")184 (-j "-emit-import-library")185 (-b "-block")186 (-types "-consult-types-file")))187188;; TODO is this up-to-date?189(define short-options190 (string->list "PHhsfiENxubvwAOeWkctgSJM") )191192193;;; Variables:194195(define scheme-files '())196(define c-files '())197(define rc-files '())198(define generated-c-files '())199(define generated-rc-files '())200(define object-files '())201(define generated-object-files '())202(define transient-link-files '())203(define linked-extensions '())204(define cpp-mode #f)205(define objc-mode #f)206(define embedded #f)207(define inquiry-only #f)208(define show-cflags #f)209(define show-ldflags #f)210(define show-libs #f)211(define dry-run #f)212(define gui #f)213(define deployed #f)214(define rpath #f)215(define ignore-repository #f)216(define show-debugging-help #f)217218(define library-dir219 (if host-mode host-libdir default-libdir))220221(define extra-libraries222 (string-split (if host-mode223 INSTALL_MORE_STATIC_LIBS224 TARGET_MORE_STATIC_LIBS)))225226(define extra-shared-libraries227 (if host-mode host-libs default-libs))228229(define (library-files)230 (list (default-library)))231232(define (shared-library-files)233 (list "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME)))234235(define translate-options '())236237(define include-dir238 (let ((id (if host-mode host-incdir default-incdir)))239 (and (not (member id '("/usr/include" "")))240 id) ) )241242(define compile-options '())243244(define builtin-compile-options245 (append246 (if include-dir (list (conc "-I" include-dir)) '())247 (cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>248 (lambda (path)249 (map (cut string-append "-I" <>) (string-split path ":;"))))250 (else '()))))251252(define compile-only-flag "-c")253(define translation-optimization-options default-translation-optimization-options)254(define compilation-optimization-options default-compilation-optimization-options)255(define linking-optimization-options default-linking-optimization-options)256257(define link-options '())258(define rpath-option (if solaris "-R" "-rpath="))259260(define (builtin-link-options)261 (append262 (cond (elf263 (list264 (conc "-L" library-dir)265 (conc "-Wl," rpath-option266 (if deployed267 "$ORIGIN"268 (if host-mode269 host-libdir270 TARGET_RUN_LIB_HOME)))))271 (aix272 (list (conc "-Wl," rpath-option library-dir)))273 (else274 (list (conc "-L" library-dir))))275 (if (and deployed (memq (software-version) '(freebsd openbsd netbsd)))276 (list "-Wl,-z,origin")277 '())278 (cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>279 (lambda (path)280 (map (cut string-append "-L" <>) (string-split path ":;"))))281 (else '()))))282283(define target-filename #f)284(define verbose #f)285(define keep-files #f)286(define translate-only #f)287(define compile-only #f)288(define to-stdout #f)289(define shared #f)290(define static #f)291292293;;; Locate object files for linking:294295(define (repo-path)296 (if host-mode297 (repository-path)298 (destination-repository 'target)))299300(define (find-object-file name)301 (let ((o (make-pathname #f name object-extension))302 (a (make-pathname #f name library-extension))303 ;; In setup mode, objects in build dir may also end with "static.o"304 (static-a (make-pathname #f name static-library-extension))305 (static-o (make-pathname #f name static-object-extension)))306 (or (file-exists? a)307 (file-exists? o)308 (and (eq? ##sys#setup-mode #t)309 (or (file-exists? static-a)310 (file-exists? static-o)))311 (and (not ignore-repository)312 (or (chicken.load#find-file a (repo-path))313 (chicken.load#find-file o (repo-path)))))))314315316;;; Display usage information:317318(define (usage)319 (let ((csc CSC_PROGRAM))320 (print #<#EOF321Usage: #{csc} [OPTION ...] [FILENAME ...]322323 `#{csc}' is a driver program for the CHICKEN compiler. Files given on the324 command line are translated, compiled or linked as needed.325326 FILENAME is a Scheme source file name with optional extension or a327 C/C++/Objective-C source, object or library file name with extension. OPTION328 may be one of the following:329330 General options:331332 -h -help display this text and exit333 -v -verbose show compiler notes and tool-invocations334 -vv display information about translation335 progress336 -vvv display information about all compilation337 stages338 -version display Scheme compiler version and exit339 -release display release number and exit340341 File and pathname options:342343 -o -output-file FILENAME specifies target executable name344 -I -include-path PATHNAME specifies alternative path for included345 files346 -to-stdout write compiler to stdout (implies -t)347 -s -shared -dynamic generate dynamically loadable shared object348 file349350 Language options:351352 -D -DSYMBOL -feature SYMBOL register feature identifier353 -no-feature SYMBOL disable builtin feature identifier354 -c++ compile via a C++ source file (.cpp)355 -objc compile via Objective-C source file (.m)356357 Syntax related options:358359 -i -case-insensitive don't preserve case of read symbols360 -K -keyword-style STYLE enable alternative keyword-syntax361 (prefix, suffix or none)362 -no-parentheses-synonyms disables list delimiter synonyms363 -no-symbol-escape disables support for escaped symbols364 -r7rs-syntax disables the CHICKEN extensions to365 R7RS syntax366 -compile-syntax macros are made available at run-time367 -j -emit-import-library MODULE write compile-time module information into368 separate file369 -J -emit-all-import-libraries emit import-libraries for all defined modules370 -no-compiler-syntax disable expansion of compiler-macros371 -m -module NAME wrap compiled code in a module372 -M -module-registration always generate module registration code373 -N -no-module-registration never generate module registration code374 (overrides `-M')375376 Translation options:377378 -x -explicit-use do not use units `library' and `eval' by379 default380 -P -check-syntax stop compilation after macro-expansion381 -A -analyze-only stop compilation after first analysis pass382383 Debugging options:384385 -w -no-warnings disable warnings386 -d0 -d1 -d2 -d3 -debug-level NUMBER387 set level of available debugging information388 -no-trace disable rudimentary debugging information389 -debug-info enable debug-information in compiled code for use390 with an external debugger391 -profile executable emits profiling information392 -accumulate-profile executable emits profiling information in393 append mode394 -profile-name FILENAME name of the generated profile information395 file396 -consult-types-file FILENAME load additional type database397398 Optimization options:399400 -O -O0 -O1 -O2 -O3 -O4 -O5 -optimize-level NUMBER401 enable certain sets of optimization options402 -optimize-leaf-routines enable leaf routine optimization403 -no-usual-integrations standard procedures may be redefined404 -u -unsafe disable safety checks405 -local assume globals are only modified in current406 file407 -b -block enable block-compilation408 -disable-interrupts disable interrupts in compiled code409 -f -fixnum-arithmetic assume all numbers are fixnums410 -disable-stack-overflow-checks disables detection of stack-overflows411 -inline enable inlining412 -inline-limit LIMIT set inlining threshold413 -inline-global enable cross-module inlining414 -specialize perform type-based specialization of primitive calls415 -oi -emit-inline-file FILENAME generate file with globally inlinable416 procedures (implies -inline -local)417 -consult-inline-file FILENAME explicitly load inline file418 -ot -emit-types-file FILENAME write type-declaration information into file419 -no-argc-checks disable argument count checks420 -no-bound-checks disable bound variable checks421 -no-procedure-checks disable procedure call checks422 -no-procedure-checks-for-usual-bindings423 disable procedure call checks only for usual424 bindings425 -no-procedure-checks-for-toplevel-bindings426 disable procedure call checks for toplevel427 bindings428 -strict-types assume variable do not change their type429 -lfa2 perform additional lightweight flow-analysis pass430 -unroll-limit LIMIT specifies inlining limit for self-recursive calls431432 Configuration options:433434 -unit NAME compile file as a library unit435 -uses NAME declare library unit as used.436 -heap-size NUMBER specifies heap-size of compiled executable437 -nursery NUMBER -stack-size NUMBER438 specifies nursery size of compiled439 executable440 -X -extend FILENAME load file before compilation commences441 -prelude EXPRESSION add expression to beginning of source file442 -postlude EXPRESSION add expression to end of source file443 -prologue FILENAME include file before main source file444 -epilogue FILENAME include file after main source file445446 -e -embedded compile as embedded447 (don't generate `main()')448 -gui compile as GUI application449 -link NAME link extension with compiled executable450 (implies -uses)451 -R -require-extension NAME require extension and import in compiled452 code453 -dll -library compile multiple units into a dynamic454 library455 -libdir DIRECTORY override directory for runtime library456457 Options to other passes:458459 -C OPTION pass option to C compiler460 -L OPTION pass option to linker461 -I<DIR> pass \"-I<DIR>\" to C compiler462 (add include path)463 -L<DIR> pass \"-L<DIR>\" to linker464 (add library path)465 -k keep intermediate files466 -c stop after compilation to object files467 -t stop after translation to C468 -cc COMPILER select other C compiler than the default469 -cxx COMPILER select other C++ compiler than the default470 -ld COMPILER select other linker than the default471 -static link with static CHICKEN libraries and472 extensions (if possible)473 -F<DIR> pass \"-F<DIR>\" to C compiler474 (add framework header path on Mac OS X)475 -framework NAME passed to linker on Mac OS X476 -rpath PATHNAME add directory to runtime library search path477 -Wl,... pass linker options478 -strip strip resulting binary479480 Inquiry options:481482 -home show home-directory (where support files go)483 -cflags show required C-compiler flags and exit484 -ldflags show required linker flags and exit485 -libs show required libraries and exit486 -cc-name show name of default C compiler used487 -cxx-name show name of default C++ compiler used488 -ld-name show name of default linker used489 -dry-run just show commands executed, don't run them490 (implies `-v')491492 Obscure options:493494 -debug MODES display debugging output for the given modes495 -compiler PATHNAME use other compiler than default `chicken'496 -raw do not generate implicit init- and exit code497 -emit-external-prototypes-first498 emit prototypes for callbacks before foreign499 declarations500 -regenerate-import-libraries emit import libraries even when unchanged501 -ignore-repository do not refer to repository for extensions502 -keep-shadowed-macros do not remove shadowed macro503 -host compile for host when configured for504 cross-compiling505 -private-repository load extensions from executable path506 -deployed link support file to be used from a deployed507 executable (sets `rpath' accordingly, if supported508 on this platform)509 -no-elevation embed manifest on Windows to supress elevation510 warnings for programs named `install' or `setup'511512 Options can be collapsed if unambiguous, so513514 -vkfO515516 is the same as517518 -v -k -fixnum-arithmetic -optimize519520 The contents of the environment variable CSC_OPTIONS are implicitly passed to521 every invocation of `#{csc}'.522523EOF524;| (for emacs font-lock)525 ) ) )526527528;;; Parse arguments:529530(define (run args)531532 (define (t-options . os)533 (set! translate-options (append translate-options os)) )534535 (define (check o r . n)536 (unless (>= (length r) (optional n 1))537 (stop "not enough arguments to option `~A'" o) ) )538539 (define (shared-build lib)540 (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))541 (set! compile-options (append pic-options '("-DC_SHARED") compile-options))542 (set! link-options543 (append544 (cond545 (osx (if lib '("-dynamiclib") '("-bundle" "-headerpad_max_install_names")))546 (else '("-shared"))) link-options))547 (set! shared #t) )548549 (define (use-private-repository)550 (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))551552 (define (generate-target-filename source-filename)553 (pathname-replace-extension554 source-filename555 (cond (shared shared-library-extension)556 (compile-only object-extension)557 (else executable-extension))))558559 (let loop ((args args))560 (cond [(null? args)561 ;; Builtin search directory options do not override explicit options562 (set! compile-options (append compile-options builtin-compile-options))563 (set! link-options (append link-options (builtin-link-options)))564 ;;565 (when inquiry-only566 (when show-cflags (print* (compiler-options) #\space))567 (when show-ldflags (print* (linker-options) #\space))568 (when show-libs (print* (linker-libraries) #\space))569 (newline)570 (exit) )571 (when (and compile-only572 (> (+ (length scheme-files)573 (length c-files))574 1))575 (stop "the `-c' option cannot be used in combination with multiple input files"))576 (cond ((null? scheme-files)577 (when (and (null? c-files)578 (null? object-files))579 (when show-debugging-help580 (exec translator (cons "bogus.scm" translate-options)))581 (stop "no source files specified") )582 (unless target-filename583 (set! target-filename584 (generate-target-filename585 (last (if (null? c-files) object-files c-files))))))586 (else587 (when (and shared (not embedded))588 (set! translate-options (cons "-dynamic" translate-options)) )589 (unless target-filename590 (set! target-filename591 (generate-target-filename (first scheme-files))))592 (run-translation)))593 (unless translate-only594 (run-compilation)595 (unless compile-only596 (when (pair? linked-extensions)597 (set! object-files ; add objects from linked extensions598 (append (filter-map find-object-file linked-extensions) object-files)))599 (when (member target-filename scheme-files)600 (fprintf (current-error-port)601 "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"602 target-filename target-filename)603 (exec (if windows-shell "move" "mv")604 (list target-filename605 (string-append target-filename ".old"))))606 (run-linking)) ) ]607 [else608 (let* ([arg (car args)]609 [rest (cdr args)]610 [s (string->symbol arg)] )611 (case s612 [(-help --help)613 (usage)614 (exit) ]615 [(-release)616 (print (chicken-version))617 (exit) ]618 [(-version)619 (exec translator '("-version"))620 (exit)]621 [(-c++)622 (set! cpp-mode #t)623 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]624 [(-objc)625 (set! objc-mode #t) ]626 [(-static)627 (set! translate-options (cons "-static" translate-options))628 (set! static #t)]629 [(-cflags)630 (set! inquiry-only #t)631 (set! show-cflags #t) ]632 [(-ldflags)633 (set! inquiry-only #t)634 (set! show-ldflags #t) ]635 [(-cc-name) (print compiler) (exit 0)]636 [(-cxx-name) (print c++-compiler) (exit 0)]637 [(-ld-name) (print linker) (exit 0)]638 [(-home) (print home) (exit 0)]639 [(-libs)640 (set! inquiry-only #t)641 (set! show-libs #t) ]642 ((-v -verbose)643 (when (number? verbose)644 (set! compile-options (cons* "-v" "-Q" compile-options))645 (set! link-options (cons "-v" link-options)) )646 (t-options "-verbose")647 (if verbose648 (set! verbose 2)649 (set! verbose #t)) )650 [(-w -no-warnings)651 (set! compile-options (cons "-w" compile-options))652 (t-options "-no-warnings") ]653 [(|-A| -analyze-only)654 (set! translate-only #t)655 (t-options "-analyze-only") ]656 [(|-P| -check-syntax)657 (set! translate-only #t)658 (t-options "-check-syntax") ]659 [(-k) (set! keep-files #t)]660 [(-c) (set! compile-only #t)]661 [(-t) (set! translate-only #t)]662 [(-e -embedded)663 (set! embedded #t)664 (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]665 [(-link)666 (check s rest)667 (t-options "-link" (car rest))668 (set! linked-extensions669 (append linked-extensions (string-split (car rest) ", ")))670 (set! rest (cdr rest))]671 ((-libdir)672 (check s rest)673 (set! library-dir (car rest))674 (set! rest (cdr rest)))675 [(-require-extension -R)676 (check s rest)677 (t-options "-require-extension" (car rest))678 (set! rest (cdr rest)) ]679 ((-private-repository)680 (use-private-repository))681 ((-ignore-repository)682 (set! ignore-repository #t)683 (t-options arg))684 ((-setup-mode)685 (set! ##sys#setup-mode #t)686 (t-options arg))687 ((-no-elevation)688 (set! generate-manifest #t))689 [(-gui)690 (set! gui #t)691 (set! compile-options (cons "-DC_GUI" compile-options))692 (when mingw693 (set! object-files694 (cons (make-pathname695 host-sharedir "chicken.rc"696 object-extension)697 object-files))698 (set! link-options699 (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"700 link-options)))]701 ((-deployed)702 (set! deployed #t))703 [(-framework)704 (check s rest)705 (when osx706 (set! link-options (cons* "-framework" (car rest) link-options)) )707 (set! rest (cdr rest)) ]708 [(-o -output-file)709 (check s rest)710 (let ([fn (car rest)])711 (set! rest (cdr rest))712 (set! target-filename fn) ) ]713 [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]714 [(|-O0|) (set! rest (cons* "-optimize-level" "0" rest))]715 [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]716 [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]717 [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]718 [(|-O5|)719 (set! rest (cons* "-optimize-level" "5" rest))]720 [(|-d0|) (set! rest (cons* "-debug-level" "0" rest))]721 [(|-d1|) (set! rest (cons* "-debug-level" "1" rest))]722 [(|-d2|) (set! rest (cons* "-debug-level" "2" rest))]723 [(|-d3|) (set! rest (cons* "-debug-level" "3" rest))]724 ((-debug)725 (check s rest)726 (t-options arg (car rest))727 (when (memv #\h (string->list (car rest)))728 (set! show-debugging-help #t)729 (set! translate-only #t))730 (set! rest (cdr rest)))731 [(-dry-run)732 (set! verbose #t)733 (set! dry-run #t)]734 [(-s -shared -dynamic)735 (shared-build #f) ]736 [(-dll -library)737 (shared-build #t) ]738 [(-compiler)739 (check s rest)740 (set! translator (car rest))741 (set! rest (cdr rest)) ]742 [(-cc)743 (check s rest)744 (set! compiler (car rest))745 (set! rest (cdr rest)) ]746 [(-cxx)747 (check s rest)748 (set! c++-compiler (car rest))749 (set! rest (cdr rest)) ]750 [(-ld)751 (check s rest)752 (set! linker (car rest))753 (set! rest (cdr rest)) ]754 [(|-I|)755 (check s rest)756 (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]757 [(|-C|)758 (check s rest)759 (set! compile-options (append compile-options (string-split (car rest))))760 (set! rest (cdr rest)) ]761 [(-strip)762 (set! link-options (append link-options (list "-s")))]763 [(|-L|)764 (check s rest)765 (set! link-options (append link-options (string-split (car rest))))766 (set! rest (cdr rest)) ]767 [(-rpath)768 (check s rest)769 (set! rpath (car rest))770 (when (and (memq (build-platform) '(gnu clang))771 (not mingw) (not osx))772 (set! link-options773 (append link-options (list (string-append "-Wl," rpath-option rpath)))) )774 (set! rest (cdr rest)) ]775 [(-host) #f]776 ((-oi)777 (check s rest)778 (t-options "-emit-inline-file" (car rest))779 (set! rest (cdr rest)))780 ((-ot)781 (check s rest)782 (t-options "-emit-types-file" (car rest))783 (set! rest (cdr rest)))784 [(-)785 (set! scheme-files (append scheme-files '("-")))786 (unless target-filename787 (set! target-filename (make-pathname #f "a" executable-extension)))]788 [else789 (when (eq? s '-to-stdout)790 (set! to-stdout #t)791 (set! translate-only #t) )792 (when (memq s '(-optimize-level -benchmark-mode))793 (set! compilation-optimization-options best-compilation-optimization-options)794 (set! linking-optimization-options best-linking-optimization-options) )795 (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]796 [(memq s simple-options) (t-options arg)]797 ((memq s complex-options)798 (check s rest)799 (t-options arg (car rest))800 (set! rest (cdr rest)))801 [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))802 (t-options arg) ]803 [(and (> (string-length arg) 1)804 (char=? #\- (string-ref arg 0)) )805 (cond [(char=? #\L (string-ref arg 1))806 (when (char-whitespace? (string-ref arg 2))807 (error "bad -L argument, <DIR> starts with whitespace" arg))808 (set! link-options (append link-options (list arg))) ]809 [(char=? #\I (string-ref arg 1))810 (when (char-whitespace? (string-ref arg 2))811 (error "bad -I argument: <DIR> starts with whitespace" arg))812 (set! compile-options (append compile-options (list arg))) ]813 [(char=? #\D (string-ref arg 1))814 (t-options "-feature" (substring arg 2)) ]815 [(char=? #\F (string-ref arg 1))816 (when osx817 (set! compile-options (append compile-options (list arg))) ) ]818 [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))819 (set! link-options (append link-options (list arg))) ]820 [(> (string-length arg) 2)821 (let ([opts (cdr (string->list arg))])822 (cond ((null? (lset-difference/eq? opts short-options))823 (set! rest824 (append (map (lambda (o)825 (string-append "-" (string o))) opts)826 rest) ))827 ((char=? #\l (car opts))828 (stop "invalid option `~A' - did you mean `-L -l<library>'?" arg))829 (else (stop "invalid option `~A'" arg) ) )) ]830 [else (stop "invalid option `~A'" s)] ) ]831 [(file-exists? arg)832 (let-values ([(dirs name ext) (decompose-pathname arg)])833 (cond [(not ext)834 (set! scheme-files (append scheme-files (list arg)))]835 [(member ext '("h" "c"))836 (set! c-files (append c-files (list arg))) ]837 ((string-ci=? ext "rc")838 (set! rc-files (append rc-files (list arg))) )839 [(member ext '("cpp" "C" "cc" "cxx" "hpp"))840 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))841 (set! cpp-mode #t)842 (set! c-files (append c-files (list arg))) ]843 [(member ext '("m" "M" "mm"))844 (set! objc-mode #t)845 (set! c-files (append c-files (list arg))) ]846 [(or (string=? ext object-extension)847 (string=? ext library-extension) )848 (set! object-files (append object-files (list arg))) ]849 [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]850 [else851 (let ([f2 (string-append arg ".scm")])852 (if (file-exists? f2)853 (set! rest (cons f2 rest))854 (stop "file `~A' does not exist" arg) ) ) ] ) ] )855 (loop rest) ) ] ) ) )856857858;;; Translate all Scheme files:859860(define (run-translation)861 (for-each862 (lambda (f)863 (let* ((sf (if (= 1 (length scheme-files))864 target-filename865 f))866 (fc (pathname-replace-extension867 sf868 (cond (cpp-mode "cpp")869 (objc-mode "m")870 (else "c") ) ) ) )871 (when (member fc c-files)872 (stop "C file generated from `~a' will overwrite explicitly given source file `~a'"873 f fc))874 (exec875 translator876 (cons* f877 (append878 (if to-stdout879 '("-to-stdout")880 `("-output-file" ,fc) )881 (if (##sys#debug-mode?)882 '("-:d")883 '())884 extra-features885 translate-options886 (if (and static887 (not (member "-emit-link-file"888 translate-options)))889 (list "-emit-link-file"890 (pathname-replace-extension fc "link"))891 '())892 (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))893 (objc-mode '("-feature" "chicken-scheme-to-objc"))894 (else '()))895 translation-optimization-options ) ) )896 (when (and static compile-only)897 (set! transient-link-files898 (cons (pathname-replace-extension f "link")899 transient-link-files)))900 (set! c-files (append (list fc) c-files))901 (set! generated-c-files (append (list fc) generated-c-files))))902 scheme-files))903904905;;; Compile all C/C++ and .rc files:906907(define (run-compilation)908 (let ((ofiles '()))909 (for-each910 (lambda (f)911 (let ((fo (if (and compile-only912 target-filename913 (= 1 (length c-files)))914 target-filename915 (pathname-replace-extension f object-extension))))916 (when (member fo object-files)917 (stop "object file generated from `~a' will overwrite explicitly given object file `~a'"918 f fo))919 (exec (cond (cpp-mode c++-compiler)920 (else compiler) )921 (cons* f922 compile-output-flag fo923 compile-only-flag924 (append (if (and cpp-mode (string=? "g++" c++-compiler)) ; XXX This is somewhat hacky - g++ might not be *named* g++925 '("-Wno-write-strings")926 '())927 (compiler-options)) ) )928 (set! generated-object-files (cons fo generated-object-files))929 (set! ofiles (cons fo ofiles))))930 c-files)931 (when (and generate-manifest (eq? 'windows (software-type)))932 (let ((rcf (pathname-replace-extension target-filename "rc")))933 (create-win-manifest (pathname-file target-filename) rcf)934 (set! rc-files (cons rcf rc-files))935 (set! generated-rc-files (cons rcf generated-rc-files))))936 (for-each937 (lambda (f)938 (let ((fo (string-append f "." object-extension)))939 (exec rc-compiler (list f fo))940 (set! generated-object-files (cons fo generated-object-files))941 (set! ofiles (cons fo ofiles))))942 rc-files)943 (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first944 (unless keep-files945 (for-each $delete-file generated-c-files)946 (for-each $delete-file generated-rc-files))))947948(define (compiler-options)949 (append950 compilation-optimization-options951 compile-options) )952953954;;; Link object files and libraries:955956(define (run-linking)957 (set! object-files958 (collect-linked-objects object-files generated-object-files))959 (exec (cond (cpp-mode c++-linker)960 (else linker) )961 (append962 object-files963 (list link-output-flag target-filename)964 (linker-options)965 (linker-libraries) ) )966 (when (and osx host-mode)967 (let ((lib (string-append (libchicken) ".dylib")))968 (exec POSTINSTALL_PROGRAM969 (list "-change" lib970 (if deployed971 (make-pathname "@executable_path" lib)972 (make-pathname (or rpath973 (if host-mode974 host-libdir975 TARGET_RUN_LIB_HOME))976 lib))977 target-filename))))978 (unless keep-files979 (for-each $delete-file980 (append generated-object-files981 transient-link-files))))982983(define (collect-linked-objects ofiles gen-ofiles)984 (define (locate-link-file o)985 (let* ((p (pathname-strip-extension o))986 ;; Also strip "static.o" extension when in setup mode:987 (f (if ##sys#setup-mode (string-chomp p ".static") p)))988 (file-exists? (make-pathname #f f "link"))))989 (define (locate-objects libs)990 (map (lambda (id)991 (or (find-object-file id)992 (stop "could not find linked extension: ~A" id)))993 (map ->string libs)))994 (let loop ((os ofiles) (os2 ofiles))995 (cond ((null? os)996 (delete-duplicates (reverse os2) string=?))997 ((or static (not (member (car os) gen-ofiles)))998 (let* ((lfile (locate-link-file (car os)))999 (newos (if lfile1000 (locate-objects (with-input-from-file lfile read))1001 '())))1002 (loop (append newos (cdr os)) (append newos os2))))1003 (else (loop (cdr os) (cons (car os) os2))))))10041005(define (copy-files from to)1006 (exec (if windows-shell "copy" "cp")1007 (append (if windows-shell '("/Y") '())1008 (list from to))))10091010(define (linker-options)1011 (append linking-optimization-options link-options) )10121013(define (linker-libraries)1014 (append1015 (if static1016 (library-files)1017 (shared-library-files))1018 (if static1019 extra-libraries1020 extra-shared-libraries)))102110221023;;; Helper procedures:10241025;; Simpler replacement for SRFI-13's string-any1026(define (string-any criteria s)1027 (let ((end (string-length s)))1028 (let lp ((i 0))1029 (let ((c (string-ref s i))1030 (i1 (+ i 1)))1031 (if (= i1 end) (criteria c)1032 (or (criteria c)1033 (lp i1)))))))10341035(define (exec prog args)1036 ;; NOTE: We construct a command line for debugging purposes, but it1037 ;; does not 100% represent what gets executed.1038 (let ((cmdline (string-intersperse (map quotewrap (cons prog args)) " ")))1039 (when verbose1040 (print cmdline))1041 (unless dry-run1042 (let*-values (((pid) (process-run prog args))1043 ((pid success? exit-code) (process-wait pid)))1044 (when (or (not success?) (not (zero? exit-code)))1045 (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" exit-code cmdline)1046 (exit exit-code))))))10471048(define ($delete-file str)1049 (when verbose1050 (print "rm " str) )1051 (unless dry-run (delete-file str) ))10521053(define (create-win-manifest prg rcfname)1054 (when verbose (print "generating " rcfname))1055 (with-output-to-file rcfname1056 (lambda ()1057 (print #<#EOF10581 24 MOVEABLE PURE1059BEGIN1060 "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>\r\n"1061 "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">\r\n"1062 " <assemblyIdentity version=""1.0.0.0"" processorArchitecture=""*"" name=""#{prg}"" type=""win32""/>\r\n"1063 " <ms_asmv2:trustInfo xmlns:ms_asmv2=""urn:schemas-microsoft-com:asm.v2"">\r\n"1064 " <ms_asmv2:security>\r\n"1065 " <ms_asmv2:requestedPrivileges>\r\n"1066 " <ms_asmv2:requestedExecutionLevel level=""asInvoker"" uiAccess=""false""/>\r\n"1067 " </ms_asmv2:requestedPrivileges>\r\n"1068 " </ms_asmv2:security>\r\n"1069 " </ms_asmv2:trustInfo>\r\n"1070 "</assembly>\r\n"1071END1072EOF1073) ) ) )107410751076;;; Run it:10771078(run1079 (append1080 (string-split (or (get-environment-variable "CSC_OPTIONS") ""))1081 arguments))10821083)