~ chicken-core (chicken-5) /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.string)4243(include "egg-environment.scm")44(include "mini-srfi-1.scm")4546(define-foreign-variable windows-shell bool "C_WINDOWS_SHELL")47(define-foreign-variable POSTINSTALL_PROGRAM c-string "C_INSTALL_POSTINSTALL_PROGRAM")48(define-foreign-variable INSTALL_LIB_NAME c-string "C_INSTALL_LIB_NAME")49(define-foreign-variable TARGET_LIB_NAME c-string "C_TARGET_LIB_NAME")50(define host-libs (foreign-value "C_INSTALL_MORE_LIBS" c-string))51(define-foreign-variable TARGET_MORE_STATIC_LIBS c-string "C_TARGET_MORE_STATIC_LIBS")52(define-foreign-variable INSTALL_MORE_STATIC_LIBS c-string "C_INSTALL_MORE_STATIC_LIBS")53(define TARGET_CC default-cc)54(define-foreign-variable CHICKEN_PROGRAM c-string "C_CHICKEN_PROGRAM")55(define-foreign-variable TARGET_FEATURES c-string "C_TARGET_FEATURES")56(define-foreign-variable TARGET_RUN_LIB_HOME c-string "C_TARGET_RUN_LIB_HOME")57(define-foreign-variable TARGET_RC_COMPILER c-string "C_TARGET_RC_COMPILER")58(define-foreign-variable INSTALL_RC_COMPILER c-string "C_INSTALL_RC_COMPILER")59(define-foreign-variable TARGET_LDFLAGS c-string "C_TARGET_LDFLAGS")60(define-foreign-variable INSTALL_LDFLAGS c-string "C_INSTALL_LDFLAGS")61(define-foreign-variable CSC_PROGRAM c-string "C_CSC_PROGRAM")626364;;; Parameters:6566(define windows (eq? (software-type) 'windows))67(define mingw (eq? (software-version) 'mingw32))68(define osx (eq? (software-version) 'macosx))69(define cygwin (eq? (software-version) 'cygwin))70(define aix (eq? (build-platform) 'aix))71(define solaris (memq (software-version) '(solaris sunos)))7273(define elf74 (memq (software-version) '(linux netbsd freebsd solaris openbsd hurd haiku)))7576(define (stop msg . args)77 (fprintf (current-error-port) "~a: ~?~%" CSC_PROGRAM msg args)78 (exit 64) )7980(define arguments (command-line-arguments))81(define cross-chicken (feature? #:cross-chicken))82(define host-mode (or (not cross-chicken) (member "-host" arguments)))8384(define (back-slash->forward-slash path)85 (if windows-shell86 (string-translate path #\\ #\/)87 path))8889(define (quotewrap str)90 (qs (back-slash->forward-slash (normalize-pathname str))))9192(define (quotewrap-no-slash-trans str)93 (qs (normalize-pathname str)))9495(define home96 (if host-mode host-sharedir default-sharedir))9798(define translator99 (quotewrap (make-pathname host-bindir CHICKEN_PROGRAM)))100101(define compiler (quotewrap (if host-mode host-cc default-cc)))102(define c++-compiler (quotewrap (if host-mode host-cxx default-cxx)))103(define rc-compiler (quotewrap (if host-mode INSTALL_RC_COMPILER TARGET_RC_COMPILER)))104(define linker (quotewrap (if host-mode host-cc default-cc)))105(define c++-linker (quotewrap (if host-mode host-cxx default-cxx)))106(define object-extension (if mingw "obj" "o"))107(define library-extension "a")108(define link-output-flag "-o ")109(define executable-extension "")110(define compile-output-flag "-o ")111(define shared-library-extension ##sys#load-dynamic-extension)112(define static-object-extension (##sys#string-append "static." object-extension))113(define static-library-extension (##sys#string-append "static." library-extension))114(define default-translation-optimization-options '())115(define pic-options (if (or mingw cygwin) '("-DPIC") '("-fPIC" "-DPIC")))116(define generate-manifest #f)117118(define (libchicken)119 (string-append "lib"120 (if (not host-mode)121 TARGET_LIB_NAME122 INSTALL_LIB_NAME)))123124(define (dynamic-libchicken)125 (if cygwin126 (string-append "cyg" INSTALL_LIB_NAME "-0") ; XXX not target127 (libchicken)))128129(define (default-library)130 (make-pathname library-dir (libchicken) library-extension))131132(define default-compilation-optimization-options133 (string-split (if host-mode host-cflags default-cflags)))134135(define best-compilation-optimization-options136 default-compilation-optimization-options)137138(define default-linking-optimization-options139 (string-split (if host-mode INSTALL_LDFLAGS TARGET_LDFLAGS)))140141(define best-linking-optimization-options142 default-linking-optimization-options)143144(define extra-features (if host-mode '() (string-split TARGET_FEATURES)))145146(define-constant simple-options147 '(-explicit-use -no-trace -no-warnings -no-usual-integrations -optimize-leaf-routines -unsafe148 -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile149 -check-syntax -case-insensitive -shared -compile-syntax -no-lambda-info150 -dynamic -disable-stack-overflow-checks -local151 -emit-external-prototypes-first -inline -release152 -analyze-only -keep-shadowed-macros -inline-global -ignore-repository153 -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax154 -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax155 -emit-all-import-libraries -no-elevation -module-registration -no-module-registration156 -no-procedure-checks-for-usual-bindings -regenerate-import-libraries157 -specialize -strict-types -clustering -lfa2 -debug-info158 -no-procedure-checks-for-toplevel-bindings))159160(define-constant complex-options161 '(-debug -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style162 -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue -emit-link-file163 -inline-limit -profile-name -unroll-limit164 -emit-inline-file -consult-inline-file165 -emit-types-file -consult-types-file166 -feature -debug-level167 -emit-import-library168 -module -link169 -no-feature))170171(define-constant shortcuts172 '((-h "-help")173 (-s "-shared")174 (-m "-module")175 (|-P| "-check-syntax")176 (-f "-fixnum-arithmetic")177 (|-D| "-feature")178 (-i "-case-insensitive")179 (|-K| "-keyword-style")180 (|-X| "-extend")181 (|-J| "-emit-all-import-libraries")182 (|-M| "-module-registration")183 (|-N| "-no-module-registration")184 (-x "-explicit-use")185 (-u "-unsafe")186 (-j "-emit-import-library")187 (-b "-block")188 (-types "-consult-types-file")))189190;; TODO is this up-to-date?191(define short-options192 (string->list "PHhsfiENxubvwAOeWkctgSJM") )193194195;;; Variables:196197(define scheme-files '())198(define c-files '())199(define rc-files '())200(define generated-c-files '())201(define generated-rc-files '())202(define object-files '())203(define generated-object-files '())204(define transient-link-files '())205(define linked-extensions '())206(define cpp-mode #f)207(define objc-mode #f)208(define embedded #f)209(define inquiry-only #f)210(define show-cflags #f)211(define show-ldflags #f)212(define show-libs #f)213(define dry-run #f)214(define gui #f)215(define deployed #f)216(define rpath #f)217(define ignore-repository #f)218(define show-debugging-help #f)219220(define library-dir221 (if host-mode host-libdir default-libdir))222223(define extra-libraries224 (if host-mode225 INSTALL_MORE_STATIC_LIBS226 TARGET_MORE_STATIC_LIBS))227228(define extra-shared-libraries229 (if host-mode host-libs default-libs))230231(define (default-library-files)232 (list (string-append "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME))))233234(define (library-files) (list (default-library)))235(define (shared-library-files) (default-library-files))236237(define translate-options '())238239(define include-dir240 (let ((id (if host-mode host-incdir default-incdir)))241 (and (not (member id '("/usr/include" "")))242 id) ) )243244(define compile-options '())245246(define builtin-compile-options247 (append248 (if include-dir (list (conc "-I" include-dir)) '())249 (cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>250 (lambda (path)251 (map (cut string-append "-I" <>) (map quotewrap (string-split path ":;")))))252 (else '()))))253254(define compile-only-flag "-c")255(define translation-optimization-options default-translation-optimization-options)256(define compilation-optimization-options default-compilation-optimization-options)257(define linking-optimization-options default-linking-optimization-options)258259(define link-options '())260(define rpath-option (if solaris "-R" "-rpath="))261262(define (builtin-link-options)263 (append264 (cond (elf265 (list266 (conc "-L" library-dir)267 (conc "-Wl," rpath-option268 (if deployed269 "$ORIGIN"270 (if host-mode271 host-libdir272 TARGET_RUN_LIB_HOME)))))273 (aix274 (list (conc "-Wl," rpath-option "\"" library-dir "\"")))275 (else276 (list (conc "-L" library-dir))))277 (if (and deployed (memq (software-version) '(freebsd openbsd netbsd)))278 (list "-Wl,-z,origin")279 '())280 (cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>281 (lambda (path)282 (map (cut string-append "-L" <>) (string-split path ":;"))))283 (else '()))))284285(define target-filename #f)286(define verbose #f)287(define keep-files #f)288(define translate-only #f)289(define compile-only #f)290(define to-stdout #f)291(define shared #f)292(define static #f)293294295;;; Locate object files for linking:296297(define (repo-path)298 (if host-mode299 (repository-path)300 (destination-repository 'target)))301302(define (find-object-file name)303 (let ((o (make-pathname #f name object-extension))304 (a (make-pathname #f name library-extension))305 ;; In setup mode, objects in build dir may also end with "static.o"306 (static-a (make-pathname #f name static-library-extension))307 (static-o (make-pathname #f name static-object-extension)))308 (or (file-exists? a)309 (file-exists? o)310 (and (eq? ##sys#setup-mode #t)311 (or (file-exists? static-a)312 (file-exists? static-o)))313 (and (not ignore-repository)314 (or (chicken.load#find-file a (repo-path))315 (chicken.load#find-file o (repo-path)))))))316317318;;; Display usage information:319320(define (usage)321 (let ((csc CSC_PROGRAM))322 (print #<#EOF323Usage: #{csc} [OPTION ...] [FILENAME ...]324325 `#{csc}' is a driver program for the CHICKEN compiler. Files given on the326 command line are translated, compiled or linked as needed.327328 FILENAME is a Scheme source file name with optional extension or a329 C/C++/Objective-C source, object or library file name with extension. OPTION330 may be one of the following:331332 General options:333334 -h -help display this text and exit335 -v -verbose show compiler notes and tool-invocations336 -vv display information about translation337 progress338 -vvv display information about all compilation339 stages340 -version display Scheme compiler version and exit341 -release display release number and exit342343 File and pathname options:344345 -o -output-file FILENAME specifies target executable name346 -I -include-path PATHNAME specifies alternative path for included347 files348 -to-stdout write compiler to stdout (implies -t)349 -s -shared -dynamic generate dynamically loadable shared object350 file351352 Language options:353354 -D -DSYMBOL -feature SYMBOL register feature identifier355 -no-feature SYMBOL disable builtin feature identifier356 -c++ compile via a C++ source file (.cpp)357 -objc compile via Objective-C source file (.m)358359 Syntax related options:360361 -i -case-insensitive don't preserve case of read symbols362 -K -keyword-style STYLE enable alternative keyword-syntax363 (prefix, suffix or none)364 -no-parentheses-synonyms disables list delimiter synonyms365 -no-symbol-escape disables support for escaped symbols366 -r5rs-syntax disables the CHICKEN extensions to367 R5RS syntax368 -compile-syntax macros are made available at run-time369 -j -emit-import-library MODULE write compile-time module information into370 separate file371 -J -emit-all-import-libraries emit import-libraries for all defined modules372 -no-compiler-syntax disable expansion of compiler-macros373 -m -module NAME wrap compiled code in a module374 -M -module-registration always generate module registration code375 -N -no-module-registration never generate module registration code376 (overrides `-M')377378 Translation options:379380 -x -explicit-use do not use units `library' and `eval' by381 default382 -P -check-syntax stop compilation after macro-expansion383 -A -analyze-only stop compilation after first analysis pass384385 Debugging options:386387 -w -no-warnings disable warnings388 -d0 -d1 -d2 -d3 -debug-level NUMBER389 set level of available debugging information390 -no-trace disable rudimentary debugging information391 -debug-info enable debug-information in compiled code for use392 with an external debugger393 -profile executable emits profiling information394 -accumulate-profile executable emits profiling information in395 append mode396 -profile-name FILENAME name of the generated profile information397 file398 -consult-types-file FILENAME load additional type database399400 Optimization options:401402 -O -O0 -O1 -O2 -O3 -O4 -O5 -optimize-level NUMBER403 enable certain sets of optimization options404 -optimize-leaf-routines enable leaf routine optimization405 -no-usual-integrations standard procedures may be redefined406 -u -unsafe disable safety checks407 -local assume globals are only modified in current408 file409 -b -block enable block-compilation410 -disable-interrupts disable interrupts in compiled code411 -f -fixnum-arithmetic assume all numbers are fixnums412 -disable-stack-overflow-checks disables detection of stack-overflows413 -inline enable inlining414 -inline-limit LIMIT set inlining threshold415 -inline-global enable cross-module inlining416 -specialize perform type-based specialization of primitive calls417 -oi -emit-inline-file FILENAME generate file with globally inlinable418 procedures (implies -inline -local)419 -consult-inline-file FILENAME explicitly load inline file420 -ot -emit-types-file FILENAME write type-declaration information into file421 -no-argc-checks disable argument count checks422 -no-bound-checks disable bound variable checks423 -no-procedure-checks disable procedure call checks424 -no-procedure-checks-for-usual-bindings425 disable procedure call checks only for usual426 bindings427 -no-procedure-checks-for-toplevel-bindings428 disable procedure call checks for toplevel429 bindings430 -strict-types assume variable do not change their type431 -clustering combine groups of local procedures into dispatch432 loop433 -lfa2 perform additional lightweight flow-analysis pass434 -unroll-limit LIMIT specifies inlining limit for self-recursive calls435436 Configuration options:437438 -unit NAME compile file as a library unit439 -uses NAME declare library unit as used.440 -heap-size NUMBER specifies heap-size of compiled executable441 -nursery NUMBER -stack-size NUMBER442 specifies nursery size of compiled443 executable444 -X -extend FILENAME load file before compilation commences445 -prelude EXPRESSION add expression to beginning of source file446 -postlude EXPRESSION add expression to end of source file447 -prologue FILENAME include file before main source file448 -epilogue FILENAME include file after main source file449450 -e -embedded compile as embedded451 (don't generate `main()')452 -gui compile as GUI application453 -link NAME link extension with compiled executable454 (implies -uses)455 -R -require-extension NAME require extension and import in compiled456 code457 -dll -library compile multiple units into a dynamic458 library459 -libdir DIRECTORY override directory for runtime library460461 Options to other passes:462463 -C OPTION pass option to C compiler464 -L OPTION pass option to linker465 -I<DIR> pass \"-I<DIR>\" to C compiler466 (add include path)467 -L<DIR> pass \"-L<DIR>\" to linker468 (add library path)469 -k keep intermediate files470 -c stop after compilation to object files471 -t stop after translation to C472 -cc COMPILER select other C compiler than the default473 -cxx COMPILER select other C++ compiler than the default474 -ld COMPILER select other linker than the default475 -static link with static CHICKEN libraries and476 extensions (if possible)477 -F<DIR> pass \"-F<DIR>\" to C compiler478 (add framework header path on Mac OS X)479 -framework NAME passed to linker on Mac OS X480 -rpath PATHNAME add directory to runtime library search path481 -Wl,... pass linker options482 -strip strip resulting binary483484 Inquiry options:485486 -home show home-directory (where support files go)487 -cflags show required C-compiler flags and exit488 -ldflags show required linker flags and exit489 -libs show required libraries and exit490 -cc-name show name of default C compiler used491 -cxx-name show name of default C++ compiler used492 -ld-name show name of default linker used493 -dry-run just show commands executed, don't run them494 (implies `-v')495496 Obscure options:497498 -debug MODES display debugging output for the given modes499 -compiler PATHNAME use other compiler than default `chicken'500 -raw do not generate implicit init- and exit code501 -emit-external-prototypes-first502 emit prototypes for callbacks before foreign503 declarations504 -regenerate-import-libraries emit import libraries even when unchanged505 -ignore-repository do not refer to repository for extensions506 -keep-shadowed-macros do not remove shadowed macro507 -host compile for host when configured for508 cross-compiling509 -private-repository load extensions from executable path510 -deployed link support file to be used from a deployed511 executable (sets `rpath' accordingly, if supported512 on this platform)513 -no-elevation embed manifest on Windows to supress elevation514 warnings for programs named `install' or `setup'515516 Options can be collapsed if unambiguous, so517518 -vkfO519520 is the same as521522 -v -k -fixnum-arithmetic -optimize523524 The contents of the environment variable CSC_OPTIONS are implicitly passed to525 every invocation of `#{csc}'.526527EOF528;| (for emacs font-lock)529 ) ) )530531532;;; Parse arguments:533534(define (run args)535536 (define (t-options . os)537 (set! translate-options (append translate-options os)) )538539 (define (check o r . n)540 (unless (>= (length r) (optional n 1))541 (stop "not enough arguments to option `~A'" o) ) )542543 (define (shared-build lib)544 (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))545 (set! compile-options (append pic-options '("-DC_SHARED") compile-options))546 (set! link-options547 (append548 (cond549 (osx (if lib '("-dynamiclib") '("-bundle" "-headerpad_max_install_names")))550 (else '("-shared"))) link-options))551 (set! shared #t) )552553 (define (use-private-repository)554 (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))555556 (define (generate-target-filename source-filename)557 (pathname-replace-extension558 source-filename559 (cond (shared shared-library-extension)560 (compile-only object-extension)561 (else executable-extension))))562563 (let loop ((args args))564 (cond [(null? args)565 ;; Builtin search directory options do not override explicit options566 (set! compile-options (append compile-options builtin-compile-options))567 (set! link-options (append link-options (builtin-link-options)))568 ;;569 (when inquiry-only570 (when show-cflags (print* (compiler-options) #\space))571 (when show-ldflags (print* (linker-options) #\space))572 (when show-libs (print* (linker-libraries) #\space))573 (newline)574 (exit) )575 (when (and compile-only576 (> (+ (length scheme-files)577 (length c-files))578 1))579 (stop "the `-c' option cannot be used in combination with multiple input files"))580 (cond ((null? scheme-files)581 (when (and (null? c-files)582 (null? object-files))583 (when show-debugging-help584 (command585 (string-intersperse586 (cons* translator "bogus.scm" translate-options))))587 (stop "no source files specified") )588 (unless target-filename589 (set! target-filename590 (generate-target-filename591 (last (if (null? c-files) object-files c-files))))))592 (else593 (when (and shared (not embedded))594 (set! translate-options (cons "-dynamic" translate-options)) )595 (unless target-filename596 (set! target-filename597 (generate-target-filename (first scheme-files))))598 (run-translation)))599 (unless translate-only600 (run-compilation)601 (unless compile-only602 (when (pair? linked-extensions)603 (set! object-files ; add objects from linked extensions604 (append (filter-map find-object-file linked-extensions) object-files)))605 (when (member target-filename scheme-files)606 (fprintf (current-error-port)607 "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"608 target-filename target-filename)609 (command610 (sprintf611 "~A ~A ~A"612 (if windows-shell "move" "mv")613 ((if windows-shell quotewrap-no-slash-trans quotewrap) target-filename)614 ((if windows-shell quotewrap-no-slash-trans quotewrap) (string-append target-filename ".old")))))615 (run-linking)) ) ]616 [else617 (let* ([arg (car args)]618 [rest (cdr args)]619 [s (string->symbol arg)] )620 (case s621 [(-help --help)622 (usage)623 (exit) ]624 [(-release)625 (print (chicken-version))626 (exit) ]627 [(-version)628 (system (sprintf "~a ~a" translator " -version"))629 (exit)]630 [(-c++)631 (set! cpp-mode #t)632 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]633 [(-objc)634 (set! objc-mode #t) ]635 [(-static)636 (set! translate-options (cons "-static" translate-options))637 (set! static #t)]638 [(-cflags)639 (set! inquiry-only #t)640 (set! show-cflags #t) ]641 [(-ldflags)642 (set! inquiry-only #t)643 (set! show-ldflags #t) ]644 [(-cc-name) (print compiler) (exit 0)]645 [(-cxx-name) (print c++-compiler) (exit 0)]646 [(-ld-name) (print linker) (exit 0)]647 [(-home) (print home) (exit 0)]648 [(-libs)649 (set! inquiry-only #t)650 (set! show-libs #t) ]651 ((-v -verbose)652 (when (number? verbose)653 (set! compile-options (cons* "-v" "-Q" compile-options))654 (set! link-options (cons "-v" link-options)) )655 (t-options "-verbose")656 (if verbose657 (set! verbose 2)658 (set! verbose #t)) )659 [(-w -no-warnings)660 (set! compile-options (cons "-w" compile-options))661 (t-options "-no-warnings") ]662 [(|-A| -analyze-only)663 (set! translate-only #t)664 (t-options "-analyze-only") ]665 [(|-P| -check-syntax)666 (set! translate-only #t)667 (t-options "-check-syntax") ]668 [(-k) (set! keep-files #t)]669 [(-c) (set! compile-only #t)]670 [(-t) (set! translate-only #t)]671 [(-e -embedded)672 (set! embedded #t)673 (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]674 [(-link)675 (check s rest)676 (t-options "-link" (car rest))677 (set! linked-extensions678 (append linked-extensions (string-split (car rest) ", ")))679 (set! rest (cdr rest))]680 ((-libdir)681 (check s rest)682 (set! library-dir (car rest))683 (set! rest (cdr rest)))684 [(-require-extension -R)685 (check s rest)686 (t-options "-require-extension" (car rest))687 (set! rest (cdr rest)) ]688 ((-private-repository)689 (use-private-repository))690 ((-ignore-repository)691 (set! ignore-repository #t)692 (t-options arg))693 ((-setup-mode)694 (set! ##sys#setup-mode #t)695 (t-options arg))696 ((-no-elevation)697 (set! generate-manifest #t))698 [(-gui)699 (set! gui #t)700 (set! compile-options (cons "-DC_GUI" compile-options))701 (when mingw702 (set! object-files703 (cons (make-pathname704 host-sharedir "chicken.rc"705 object-extension)706 object-files))707 (set! link-options708 (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"709 link-options)))]710 ((-deployed)711 (set! deployed #t))712 [(-framework)713 (check s rest)714 (when osx715 (set! link-options (cons* "-framework" (car rest) link-options)) )716 (set! rest (cdr rest)) ]717 [(-o -output-file)718 (check s rest)719 (let ([fn (car rest)])720 (set! rest (cdr rest))721 (set! target-filename fn) ) ]722 [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]723 [(|-O0|) (set! rest (cons* "-optimize-level" "0" rest))]724 [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]725 [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]726 [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]727 [(|-O5|)728 (set! rest (cons* "-optimize-level" "5" rest))]729 [(|-d0|) (set! rest (cons* "-debug-level" "0" rest))]730 [(|-d1|) (set! rest (cons* "-debug-level" "1" rest))]731 [(|-d2|) (set! rest (cons* "-debug-level" "2" rest))]732 [(|-d3|) (set! rest (cons* "-debug-level" "3" rest))]733 ((-debug)734 (check s rest)735 (t-options arg (car rest))736 (when (memv #\h (string->list (car rest)))737 (set! show-debugging-help #t)738 (set! translate-only #t))739 (set! rest (cdr rest)))740 [(-dry-run)741 (set! verbose #t)742 (set! dry-run #t)]743 [(-s -shared -dynamic)744 (shared-build #f) ]745 [(-dll -library)746 (shared-build #t) ]747 [(-compiler)748 (check s rest)749 (set! translator (car rest))750 (set! rest (cdr rest)) ]751 [(-cc)752 (check s rest)753 (set! compiler (car rest))754 (set! rest (cdr rest)) ]755 [(-cxx)756 (check s rest)757 (set! c++-compiler (car rest))758 (set! rest (cdr rest)) ]759 [(-ld)760 (check s rest)761 (set! linker (car rest))762 (set! rest (cdr rest)) ]763 [(|-I|)764 (check s rest)765 (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]766 [(|-C|)767 (check s rest)768 (set! compile-options (append compile-options (string-split (car rest))))769 (set! rest (cdr rest)) ]770 [(-strip)771 (set! link-options (append link-options (list "-s")))]772 [(|-L|)773 (check s rest)774 (set! link-options (append link-options (string-split (car rest))))775 (set! rest (cdr rest)) ]776 [(-rpath)777 (check s rest)778 (set! rpath (car rest))779 (when (and (memq (build-platform) '(gnu clang))780 (not mingw) (not osx))781 (set! link-options782 (append link-options (list (string-append "-Wl," rpath-option rpath)))) )783 (set! rest (cdr rest)) ]784 [(-host) #f]785 ((-oi)786 (check s rest)787 (t-options "-emit-inline-file" (car rest))788 (set! rest (cdr rest)))789 ((-ot)790 (check s rest)791 (t-options "-emit-types-file" (car rest))792 (set! rest (cdr rest)))793 [(-)794 (set! scheme-files (append scheme-files '("-")))795 (unless target-filename796 (set! target-filename (make-pathname #f "a" executable-extension)))]797 [else798 (when (eq? s '-to-stdout)799 (set! to-stdout #t)800 (set! translate-only #t) )801 (when (memq s '(-optimize-level -benchmark-mode))802 (set! compilation-optimization-options best-compilation-optimization-options)803 (set! linking-optimization-options best-linking-optimization-options) )804 (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]805 [(memq s simple-options) (t-options arg)]806 ((memq s complex-options)807 (check s rest)808 (t-options arg (car rest))809 (set! rest (cdr rest)))810 [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))811 (t-options arg) ]812 [(and (> (string-length arg) 1)813 (char=? #\- (string-ref arg 0)) )814 (cond [(char=? #\L (string-ref arg 1))815 (when (char-whitespace? (string-ref arg 2))816 (error "bad -L argument, <DIR> starts with whitespace" arg))817 (set! link-options (append link-options (list arg))) ]818 [(char=? #\I (string-ref arg 1))819 (when (char-whitespace? (string-ref arg 2))820 (error "bad -I argument: <DIR> starts with whitespace" arg))821 (set! compile-options (append compile-options (list arg))) ]822 [(char=? #\D (string-ref arg 1))823 (t-options "-feature" (substring arg 2)) ]824 [(char=? #\F (string-ref arg 1))825 (when osx826 (set! compile-options (append compile-options (list arg))) ) ]827 [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))828 (set! link-options (append link-options (list arg))) ]829 [(> (string-length arg) 2)830 (let ([opts (cdr (string->list arg))])831 (cond ((null? (lset-difference/eq? opts short-options))832 (set! rest833 (append (map (lambda (o)834 (string-append "-" (string o))) opts)835 rest) ))836 ((char=? #\l (car opts))837 (stop "invalid option `~A' - did you mean `-L -l<library>'?" arg))838 (else (stop "invalid option `~A'" arg) ) )) ]839 [else (stop "invalid option `~A'" s)] ) ]840 [(file-exists? arg)841 (let-values ([(dirs name ext) (decompose-pathname arg)])842 (cond [(not ext)843 (set! scheme-files (append scheme-files (list arg)))]844 [(member ext '("h" "c"))845 (set! c-files (append c-files (list arg))) ]846 ((string-ci=? ext "rc")847 (set! rc-files (append rc-files (list arg))) )848 [(member ext '("cpp" "C" "cc" "cxx" "hpp"))849 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))850 (set! cpp-mode #t)851 (set! c-files (append c-files (list arg))) ]852 [(member ext '("m" "M" "mm"))853 (set! objc-mode #t)854 (set! c-files (append c-files (list arg))) ]855 [(or (string=? ext object-extension)856 (string=? ext library-extension) )857 (set! object-files (append object-files (list arg))) ]858 [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]859 [else860 (let ([f2 (string-append arg ".scm")])861 (if (file-exists? f2)862 (set! rest (cons f2 rest))863 (stop "file `~A' does not exist" arg) ) ) ] ) ] )864 (loop rest) ) ] ) ) )865866867;;; Translate all Scheme files:868869(define (run-translation)870 (for-each871 (lambda (f)872 (let* ((sf (if (= 1 (length scheme-files))873 target-filename874 f))875 (fc (pathname-replace-extension876 sf877 (cond (cpp-mode "cpp")878 (objc-mode "m")879 (else "c") ) ) ) )880 (when (member fc c-files)881 (stop "C file generated from `~a' will overwrite explicitly given source file `~a'"882 f fc))883 (command884 (string-intersperse885 (cons* translator (quotewrap f)886 (append887 (if to-stdout888 '("-to-stdout")889 `("-output-file" ,(quotewrap fc)) )890 (if (##sys#debug-mode?)891 '("-:d")892 '())893 (map quote-option894 (append895 extra-features896 translate-options897 (if (and static898 (not (member "-emit-link-file"899 translate-options)))900 (list "-emit-link-file"901 (pathname-replace-extension fc "link"))902 '())903 (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))904 (objc-mode '("-feature" "chicken-scheme-to-objc"))905 (else '()))906 translation-optimization-options)) ) )907 " ") )908 (when (and static compile-only)909 (set! transient-link-files910 (cons (pathname-replace-extension f "link")911 transient-link-files)))912 (set! c-files (append (list fc) c-files))913 (set! generated-c-files (append (list fc) generated-c-files))))914 scheme-files))915916917;;; Compile all C/C++ and .rc files:918919(define (run-compilation)920 (let ((ofiles '()))921 (for-each922 (lambda (f)923 (let ((fo (if (and compile-only924 target-filename925 (= 1 (length c-files)))926 target-filename927 (pathname-replace-extension f object-extension))))928 (when (member fo object-files)929 (stop "object file generated from `~a' will overwrite explicitly given object file `~a'"930 f fo))931 (command932 (string-intersperse933 (list (cond (cpp-mode c++-compiler)934 (else compiler) )935 (quotewrap f)936 (string-append compile-output-flag (quotewrap fo))937 compile-only-flag938 (if (and cpp-mode (string=? "g++" c++-compiler))939 "-Wno-write-strings"940 "")941 (compiler-options) ) ) )942 (set! generated-object-files (cons fo generated-object-files))943 (set! ofiles (cons fo ofiles))))944 c-files)945 (when (and generate-manifest (eq? 'windows (software-type)))946 (let ((rcf (pathname-replace-extension target-filename "rc")))947 (create-win-manifest (pathname-file target-filename) rcf)948 (set! rc-files (cons rcf rc-files))949 (set! generated-rc-files (cons rcf generated-rc-files))))950 (for-each951 (lambda (f)952 (let ((fo (string-append f "." object-extension)))953 (command954 (string-intersperse955 (list rc-compiler (quotewrap f) (quotewrap fo))))956 (set! generated-object-files (cons fo generated-object-files))957 (set! ofiles (cons fo ofiles))))958 rc-files)959 (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first960 (unless keep-files961 (for-each $delete-file generated-c-files)962 (for-each $delete-file generated-rc-files))))963964(define (compiler-options)965 (string-intersperse966 (map quote-option967 (append968 compilation-optimization-options969 compile-options) ) ) )970971972;;; Link object files and libraries:973974(define (run-linking)975 (set! object-files976 (collect-linked-objects object-files generated-object-files))977 (let* ((files (map quotewrap object-files))978 (target (quotewrap target-filename))979 (targetdir #f))980 (command981 (string-intersperse982 (cons* (cond (cpp-mode c++-linker)983 (else linker) )984 (append985 files986 (list (string-append link-output-flag (quotewrap target-filename))987 (linker-options)988 (linker-libraries) ) ) ) ) )989 (when (and osx host-mode)990 (command991 (string-append992 POSTINSTALL_PROGRAM " -change " (libchicken) ".dylib "993 (quotewrap994 (let ((lib (string-append (libchicken) ".dylib")))995 (if deployed996 (make-pathname "@executable_path" lib)997 (make-pathname (if host-mode998 host-libdir999 TARGET_RUN_LIB_HOME)1000 lib))))1001 " "1002 target) ))1003 (unless keep-files1004 (for-each $delete-file1005 (append generated-object-files1006 transient-link-files)))))10071008(define (collect-linked-objects ofiles gen-ofiles)1009 (define (locate-link-file o)1010 (let* ((p (pathname-strip-extension o))1011 ;; Also strip "static.o" extension when in setup mode:1012 (f (if ##sys#setup-mode (string-chomp p ".static") p)))1013 (file-exists? (make-pathname #f f "link"))))1014 (define (locate-objects libs)1015 (map (lambda (id)1016 (or (find-object-file id)1017 (stop "could not find linked extension: ~A" id)))1018 (map ->string libs)))1019 (let loop ((os ofiles) (os2 ofiles))1020 (cond ((null? os)1021 (delete-duplicates (reverse os2) string=?))1022 ((or static (not (member (car os) gen-ofiles)))1023 (let* ((lfile (locate-link-file (car os)))1024 (newos (if lfile1025 (locate-objects (with-input-from-file lfile read))1026 '())))1027 (loop (append newos (cdr os)) (append newos os2))))1028 (else (loop (cdr os) (cons (car os) os2))))))10291030(define (copy-files from to)1031 (command1032 (sprintf "~a ~a ~a"1033 (if windows-shell1034 "copy /Y"1035 "cp")1036 ((if windows-shell quotewrap-no-slash-trans quotewrap) from)1037 ((if windows-shell quotewrap-no-slash-trans quotewrap) to))))10381039(define (linker-options)1040 (string-intersperse1041 (map quote-option1042 (append linking-optimization-options link-options) ) ) )10431044(define (linker-libraries)1045 (string-intersperse1046 (append1047 (if static1048 (library-files)1049 (shared-library-files))1050 (if static1051 (list extra-libraries)1052 (list extra-shared-libraries)))))105310541055;;; Helper procedures:10561057;; Simpler replacement for SRFI-13's string-any1058(define (string-any criteria s)1059 (let ((end (string-length s)))1060 (let lp ((i 0))1061 (let ((c (string-ref s i))1062 (i1 (+ i 1)))1063 (if (= i1 end) (criteria c)1064 (or (criteria c)1065 (lp i1)))))))10661067(define quote-option qs)10681069(define last-exit-code #f)10701071(define ($system str)1072 (let ((str (cond (windows-shell1073 (string-append "\"" str "\""))1074 ((and osx (get-environment-variable "DYLD_LIBRARY_PATH"))1075 => (lambda (path)1076 (string-append "/usr/bin/env DYLD_LIBRARY_PATH="1077 (qs path) " " str)))1078 (else str))))1079 (when verbose (print str))1080 (let ((raw-exit-code (if dry-run 0 (system str))))1081 (unless (zero? raw-exit-code)1082 (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" raw-exit-code str))1083 (set! last-exit-code1084 (if (zero? raw-exit-code) 0 1))1085 last-exit-code)))10861087(define (command str)1088 (unless (zero? ($system str))1089 (exit last-exit-code)))10901091(define ($delete-file str)1092 (when verbose1093 (print "rm " str) )1094 (unless dry-run (delete-file str) ))10951096(define (create-win-manifest prg rcfname)1097 (when verbose (print "generating " rcfname))1098 (with-output-to-file rcfname1099 (lambda ()1100 (print #<#EOF11011 24 MOVEABLE PURE1102BEGIN1103 "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>\r\n"1104 "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">\r\n"1105 " <assemblyIdentity version=""1.0.0.0"" processorArchitecture=""*"" name=""#{prg}"" type=""win32""/>\r\n"1106 " <ms_asmv2:trustInfo xmlns:ms_asmv2=""urn:schemas-microsoft-com:asm.v2"">\r\n"1107 " <ms_asmv2:security>\r\n"1108 " <ms_asmv2:requestedPrivileges>\r\n"1109 " <ms_asmv2:requestedExecutionLevel level=""asInvoker"" uiAccess=""false""/>\r\n"1110 " </ms_asmv2:requestedPrivileges>\r\n"1111 " </ms_asmv2:security>\r\n"1112 " </ms_asmv2:trustInfo>\r\n"1113 "</assembly>\r\n"1114END1115EOF1116) ) ) )111711181119;;; Run it:11201121(run1122 (append1123 (string-split (or (get-environment-variable "CSC_OPTIONS") ""))1124 arguments))11251126)