~ 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 -clustering -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 -clustering combine groups of local procedures into dispatch430 loop431 -lfa2 perform additional lightweight flow-analysis pass432 -unroll-limit LIMIT specifies inlining limit for self-recursive calls433434 Configuration options:435436 -unit NAME compile file as a library unit437 -uses NAME declare library unit as used.438 -heap-size NUMBER specifies heap-size of compiled executable439 -nursery NUMBER -stack-size NUMBER440 specifies nursery size of compiled441 executable442 -X -extend FILENAME load file before compilation commences443 -prelude EXPRESSION add expression to beginning of source file444 -postlude EXPRESSION add expression to end of source file445 -prologue FILENAME include file before main source file446 -epilogue FILENAME include file after main source file447448 -e -embedded compile as embedded449 (don't generate `main()')450 -gui compile as GUI application451 -link NAME link extension with compiled executable452 (implies -uses)453 -R -require-extension NAME require extension and import in compiled454 code455 -dll -library compile multiple units into a dynamic456 library457 -libdir DIRECTORY override directory for runtime library458459 Options to other passes:460461 -C OPTION pass option to C compiler462 -L OPTION pass option to linker463 -I<DIR> pass \"-I<DIR>\" to C compiler464 (add include path)465 -L<DIR> pass \"-L<DIR>\" to linker466 (add library path)467 -k keep intermediate files468 -c stop after compilation to object files469 -t stop after translation to C470 -cc COMPILER select other C compiler than the default471 -cxx COMPILER select other C++ compiler than the default472 -ld COMPILER select other linker than the default473 -static link with static CHICKEN libraries and474 extensions (if possible)475 -F<DIR> pass \"-F<DIR>\" to C compiler476 (add framework header path on Mac OS X)477 -framework NAME passed to linker on Mac OS X478 -rpath PATHNAME add directory to runtime library search path479 -Wl,... pass linker options480 -strip strip resulting binary481482 Inquiry options:483484 -home show home-directory (where support files go)485 -cflags show required C-compiler flags and exit486 -ldflags show required linker flags and exit487 -libs show required libraries and exit488 -cc-name show name of default C compiler used489 -cxx-name show name of default C++ compiler used490 -ld-name show name of default linker used491 -dry-run just show commands executed, don't run them492 (implies `-v')493494 Obscure options:495496 -debug MODES display debugging output for the given modes497 -compiler PATHNAME use other compiler than default `chicken'498 -raw do not generate implicit init- and exit code499 -emit-external-prototypes-first500 emit prototypes for callbacks before foreign501 declarations502 -regenerate-import-libraries emit import libraries even when unchanged503 -ignore-repository do not refer to repository for extensions504 -keep-shadowed-macros do not remove shadowed macro505 -host compile for host when configured for506 cross-compiling507 -private-repository load extensions from executable path508 -deployed link support file to be used from a deployed509 executable (sets `rpath' accordingly, if supported510 on this platform)511 -no-elevation embed manifest on Windows to supress elevation512 warnings for programs named `install' or `setup'513514 Options can be collapsed if unambiguous, so515516 -vkfO517518 is the same as519520 -v -k -fixnum-arithmetic -optimize521522 The contents of the environment variable CSC_OPTIONS are implicitly passed to523 every invocation of `#{csc}'.524525EOF526;| (for emacs font-lock)527 ) ) )528529530;;; Parse arguments:531532(define (run args)533534 (define (t-options . os)535 (set! translate-options (append translate-options os)) )536537 (define (check o r . n)538 (unless (>= (length r) (optional n 1))539 (stop "not enough arguments to option `~A'" o) ) )540541 (define (shared-build lib)542 (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))543 (set! compile-options (append pic-options '("-DC_SHARED") compile-options))544 (set! link-options545 (append546 (cond547 (osx (if lib '("-dynamiclib") '("-bundle" "-headerpad_max_install_names")))548 (else '("-shared"))) link-options))549 (set! shared #t) )550551 (define (use-private-repository)552 (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))553554 (define (generate-target-filename source-filename)555 (pathname-replace-extension556 source-filename557 (cond (shared shared-library-extension)558 (compile-only object-extension)559 (else executable-extension))))560561 (let loop ((args args))562 (cond [(null? args)563 ;; Builtin search directory options do not override explicit options564 (set! compile-options (append compile-options builtin-compile-options))565 (set! link-options (append link-options (builtin-link-options)))566 ;;567 (when inquiry-only568 (when show-cflags (print* (compiler-options) #\space))569 (when show-ldflags (print* (linker-options) #\space))570 (when show-libs (print* (linker-libraries) #\space))571 (newline)572 (exit) )573 (when (and compile-only574 (> (+ (length scheme-files)575 (length c-files))576 1))577 (stop "the `-c' option cannot be used in combination with multiple input files"))578 (cond ((null? scheme-files)579 (when (and (null? c-files)580 (null? object-files))581 (when show-debugging-help582 (exec translator (cons "bogus.scm" translate-options)))583 (stop "no source files specified") )584 (unless target-filename585 (set! target-filename586 (generate-target-filename587 (last (if (null? c-files) object-files c-files))))))588 (else589 (when (and shared (not embedded))590 (set! translate-options (cons "-dynamic" translate-options)) )591 (unless target-filename592 (set! target-filename593 (generate-target-filename (first scheme-files))))594 (run-translation)))595 (unless translate-only596 (run-compilation)597 (unless compile-only598 (when (pair? linked-extensions)599 (set! object-files ; add objects from linked extensions600 (append (filter-map find-object-file linked-extensions) object-files)))601 (when (member target-filename scheme-files)602 (fprintf (current-error-port)603 "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"604 target-filename target-filename)605 (exec (if windows-shell "move" "mv")606 (list target-filename607 (string-append target-filename ".old"))))608 (run-linking)) ) ]609 [else610 (let* ([arg (car args)]611 [rest (cdr args)]612 [s (string->symbol arg)] )613 (case s614 [(-help --help)615 (usage)616 (exit) ]617 [(-release)618 (print (chicken-version))619 (exit) ]620 [(-version)621 (exec translator '("-version"))622 (exit)]623 [(-c++)624 (set! cpp-mode #t)625 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]626 [(-objc)627 (set! objc-mode #t) ]628 [(-static)629 (set! translate-options (cons "-static" translate-options))630 (set! static #t)]631 [(-cflags)632 (set! inquiry-only #t)633 (set! show-cflags #t) ]634 [(-ldflags)635 (set! inquiry-only #t)636 (set! show-ldflags #t) ]637 [(-cc-name) (print compiler) (exit 0)]638 [(-cxx-name) (print c++-compiler) (exit 0)]639 [(-ld-name) (print linker) (exit 0)]640 [(-home) (print home) (exit 0)]641 [(-libs)642 (set! inquiry-only #t)643 (set! show-libs #t) ]644 ((-v -verbose)645 (when (number? verbose)646 (set! compile-options (cons* "-v" "-Q" compile-options))647 (set! link-options (cons "-v" link-options)) )648 (t-options "-verbose")649 (if verbose650 (set! verbose 2)651 (set! verbose #t)) )652 [(-w -no-warnings)653 (set! compile-options (cons "-w" compile-options))654 (t-options "-no-warnings") ]655 [(|-A| -analyze-only)656 (set! translate-only #t)657 (t-options "-analyze-only") ]658 [(|-P| -check-syntax)659 (set! translate-only #t)660 (t-options "-check-syntax") ]661 [(-k) (set! keep-files #t)]662 [(-c) (set! compile-only #t)]663 [(-t) (set! translate-only #t)]664 [(-e -embedded)665 (set! embedded #t)666 (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]667 [(-link)668 (check s rest)669 (t-options "-link" (car rest))670 (set! linked-extensions671 (append linked-extensions (string-split (car rest) ", ")))672 (set! rest (cdr rest))]673 ((-libdir)674 (check s rest)675 (set! library-dir (car rest))676 (set! rest (cdr rest)))677 [(-require-extension -R)678 (check s rest)679 (t-options "-require-extension" (car rest))680 (set! rest (cdr rest)) ]681 ((-private-repository)682 (use-private-repository))683 ((-ignore-repository)684 (set! ignore-repository #t)685 (t-options arg))686 ((-setup-mode)687 (set! ##sys#setup-mode #t)688 (t-options arg))689 ((-no-elevation)690 (set! generate-manifest #t))691 [(-gui)692 (set! gui #t)693 (set! compile-options (cons "-DC_GUI" compile-options))694 (when mingw695 (set! object-files696 (cons (make-pathname697 host-sharedir "chicken.rc"698 object-extension)699 object-files))700 (set! link-options701 (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"702 link-options)))]703 ((-deployed)704 (set! deployed #t))705 [(-framework)706 (check s rest)707 (when osx708 (set! link-options (cons* "-framework" (car rest) link-options)) )709 (set! rest (cdr rest)) ]710 [(-o -output-file)711 (check s rest)712 (let ([fn (car rest)])713 (set! rest (cdr rest))714 (set! target-filename fn) ) ]715 [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]716 [(|-O0|) (set! rest (cons* "-optimize-level" "0" rest))]717 [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]718 [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]719 [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]720 [(|-O5|)721 (set! rest (cons* "-optimize-level" "5" rest))]722 [(|-d0|) (set! rest (cons* "-debug-level" "0" rest))]723 [(|-d1|) (set! rest (cons* "-debug-level" "1" rest))]724 [(|-d2|) (set! rest (cons* "-debug-level" "2" rest))]725 [(|-d3|) (set! rest (cons* "-debug-level" "3" rest))]726 ((-debug)727 (check s rest)728 (t-options arg (car rest))729 (when (memv #\h (string->list (car rest)))730 (set! show-debugging-help #t)731 (set! translate-only #t))732 (set! rest (cdr rest)))733 [(-dry-run)734 (set! verbose #t)735 (set! dry-run #t)]736 [(-s -shared -dynamic)737 (shared-build #f) ]738 [(-dll -library)739 (shared-build #t) ]740 [(-compiler)741 (check s rest)742 (set! translator (car rest))743 (set! rest (cdr rest)) ]744 [(-cc)745 (check s rest)746 (set! compiler (car rest))747 (set! rest (cdr rest)) ]748 [(-cxx)749 (check s rest)750 (set! c++-compiler (car rest))751 (set! rest (cdr rest)) ]752 [(-ld)753 (check s rest)754 (set! linker (car rest))755 (set! rest (cdr rest)) ]756 [(|-I|)757 (check s rest)758 (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]759 [(|-C|)760 (check s rest)761 (set! compile-options (append compile-options (string-split (car rest))))762 (set! rest (cdr rest)) ]763 [(-strip)764 (set! link-options (append link-options (list "-s")))]765 [(|-L|)766 (check s rest)767 (set! link-options (append link-options (string-split (car rest))))768 (set! rest (cdr rest)) ]769 [(-rpath)770 (check s rest)771 (set! rpath (car rest))772 (when (and (memq (build-platform) '(gnu clang))773 (not mingw) (not osx))774 (set! link-options775 (append link-options (list (string-append "-Wl," rpath-option rpath)))) )776 (set! rest (cdr rest)) ]777 [(-host) #f]778 ((-oi)779 (check s rest)780 (t-options "-emit-inline-file" (car rest))781 (set! rest (cdr rest)))782 ((-ot)783 (check s rest)784 (t-options "-emit-types-file" (car rest))785 (set! rest (cdr rest)))786 [(-)787 (set! scheme-files (append scheme-files '("-")))788 (unless target-filename789 (set! target-filename (make-pathname #f "a" executable-extension)))]790 [else791 (when (eq? s '-to-stdout)792 (set! to-stdout #t)793 (set! translate-only #t) )794 (when (memq s '(-optimize-level -benchmark-mode))795 (set! compilation-optimization-options best-compilation-optimization-options)796 (set! linking-optimization-options best-linking-optimization-options) )797 (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]798 [(memq s simple-options) (t-options arg)]799 ((memq s complex-options)800 (check s rest)801 (t-options arg (car rest))802 (set! rest (cdr rest)))803 [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))804 (t-options arg) ]805 [(and (> (string-length arg) 1)806 (char=? #\- (string-ref arg 0)) )807 (cond [(char=? #\L (string-ref arg 1))808 (when (char-whitespace? (string-ref arg 2))809 (error "bad -L argument, <DIR> starts with whitespace" arg))810 (set! link-options (append link-options (list arg))) ]811 [(char=? #\I (string-ref arg 1))812 (when (char-whitespace? (string-ref arg 2))813 (error "bad -I argument: <DIR> starts with whitespace" arg))814 (set! compile-options (append compile-options (list arg))) ]815 [(char=? #\D (string-ref arg 1))816 (t-options "-feature" (substring arg 2)) ]817 [(char=? #\F (string-ref arg 1))818 (when osx819 (set! compile-options (append compile-options (list arg))) ) ]820 [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))821 (set! link-options (append link-options (list arg))) ]822 [(> (string-length arg) 2)823 (let ([opts (cdr (string->list arg))])824 (cond ((null? (lset-difference/eq? opts short-options))825 (set! rest826 (append (map (lambda (o)827 (string-append "-" (string o))) opts)828 rest) ))829 ((char=? #\l (car opts))830 (stop "invalid option `~A' - did you mean `-L -l<library>'?" arg))831 (else (stop "invalid option `~A'" arg) ) )) ]832 [else (stop "invalid option `~A'" s)] ) ]833 [(file-exists? arg)834 (let-values ([(dirs name ext) (decompose-pathname arg)])835 (cond [(not ext)836 (set! scheme-files (append scheme-files (list arg)))]837 [(member ext '("h" "c"))838 (set! c-files (append c-files (list arg))) ]839 ((string-ci=? ext "rc")840 (set! rc-files (append rc-files (list arg))) )841 [(member ext '("cpp" "C" "cc" "cxx" "hpp"))842 (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))843 (set! cpp-mode #t)844 (set! c-files (append c-files (list arg))) ]845 [(member ext '("m" "M" "mm"))846 (set! objc-mode #t)847 (set! c-files (append c-files (list arg))) ]848 [(or (string=? ext object-extension)849 (string=? ext library-extension) )850 (set! object-files (append object-files (list arg))) ]851 [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]852 [else853 (let ([f2 (string-append arg ".scm")])854 (if (file-exists? f2)855 (set! rest (cons f2 rest))856 (stop "file `~A' does not exist" arg) ) ) ] ) ] )857 (loop rest) ) ] ) ) )858859860;;; Translate all Scheme files:861862(define (run-translation)863 (for-each864 (lambda (f)865 (let* ((sf (if (= 1 (length scheme-files))866 target-filename867 f))868 (fc (pathname-replace-extension869 sf870 (cond (cpp-mode "cpp")871 (objc-mode "m")872 (else "c") ) ) ) )873 (when (member fc c-files)874 (stop "C file generated from `~a' will overwrite explicitly given source file `~a'"875 f fc))876 (exec877 translator878 (cons* f879 (append880 (if to-stdout881 '("-to-stdout")882 `("-output-file" ,fc) )883 (if (##sys#debug-mode?)884 '("-:d")885 '())886 extra-features887 translate-options888 (if (and static889 (not (member "-emit-link-file"890 translate-options)))891 (list "-emit-link-file"892 (pathname-replace-extension fc "link"))893 '())894 (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))895 (objc-mode '("-feature" "chicken-scheme-to-objc"))896 (else '()))897 translation-optimization-options ) ) )898 (when (and static compile-only)899 (set! transient-link-files900 (cons (pathname-replace-extension f "link")901 transient-link-files)))902 (set! c-files (append (list fc) c-files))903 (set! generated-c-files (append (list fc) generated-c-files))))904 scheme-files))905906907;;; Compile all C/C++ and .rc files:908909(define (run-compilation)910 (let ((ofiles '()))911 (for-each912 (lambda (f)913 (let ((fo (if (and compile-only914 target-filename915 (= 1 (length c-files)))916 target-filename917 (pathname-replace-extension f object-extension))))918 (when (member fo object-files)919 (stop "object file generated from `~a' will overwrite explicitly given object file `~a'"920 f fo))921 (exec (cond (cpp-mode c++-compiler)922 (else compiler) )923 (cons* f924 compile-output-flag fo925 compile-only-flag926 (append (if (and cpp-mode (string=? "g++" c++-compiler)) ; XXX This is somewhat hacky - g++ might not be *named* g++927 '("-Wno-write-strings")928 '())929 (compiler-options)) ) )930 (set! generated-object-files (cons fo generated-object-files))931 (set! ofiles (cons fo ofiles))))932 c-files)933 (when (and generate-manifest (eq? 'windows (software-type)))934 (let ((rcf (pathname-replace-extension target-filename "rc")))935 (create-win-manifest (pathname-file target-filename) rcf)936 (set! rc-files (cons rcf rc-files))937 (set! generated-rc-files (cons rcf generated-rc-files))))938 (for-each939 (lambda (f)940 (let ((fo (string-append f "." object-extension)))941 (exec rc-compiler (list f fo))942 (set! generated-object-files (cons fo generated-object-files))943 (set! ofiles (cons fo ofiles))))944 rc-files)945 (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first946 (unless keep-files947 (for-each $delete-file generated-c-files)948 (for-each $delete-file generated-rc-files))))949950(define (compiler-options)951 (append952 compilation-optimization-options953 compile-options) )954955956;;; Link object files and libraries:957958(define (run-linking)959 (set! object-files960 (collect-linked-objects object-files generated-object-files))961 (exec (cond (cpp-mode c++-linker)962 (else linker) )963 (append964 object-files965 (list link-output-flag target-filename)966 (linker-options)967 (linker-libraries) ) )968 (when (and osx host-mode)969 (let ((lib (string-append (libchicken) ".dylib")))970 (exec POSTINSTALL_PROGRAM971 (list "-change" lib972 (if deployed973 (make-pathname "@executable_path" lib)974 (make-pathname (or rpath975 (if host-mode976 host-libdir977 TARGET_RUN_LIB_HOME))978 lib))979 target-filename))))980 (unless keep-files981 (for-each $delete-file982 (append generated-object-files983 transient-link-files))))984985(define (collect-linked-objects ofiles gen-ofiles)986 (define (locate-link-file o)987 (let* ((p (pathname-strip-extension o))988 ;; Also strip "static.o" extension when in setup mode:989 (f (if ##sys#setup-mode (string-chomp p ".static") p)))990 (file-exists? (make-pathname #f f "link"))))991 (define (locate-objects libs)992 (map (lambda (id)993 (or (find-object-file id)994 (stop "could not find linked extension: ~A" id)))995 (map ->string libs)))996 (let loop ((os ofiles) (os2 ofiles))997 (cond ((null? os)998 (delete-duplicates (reverse os2) string=?))999 ((or static (not (member (car os) gen-ofiles)))1000 (let* ((lfile (locate-link-file (car os)))1001 (newos (if lfile1002 (locate-objects (with-input-from-file lfile read))1003 '())))1004 (loop (append newos (cdr os)) (append newos os2))))1005 (else (loop (cdr os) (cons (car os) os2))))))10061007(define (copy-files from to)1008 (exec (if windows-shell "copy" "cp")1009 (append (if windows-shell '("/Y") '())1010 (list from to))))10111012(define (linker-options)1013 (append linking-optimization-options link-options) )10141015(define (linker-libraries)1016 (append1017 (if static1018 (library-files)1019 (shared-library-files))1020 (if static1021 extra-libraries1022 extra-shared-libraries)))102310241025;;; Helper procedures:10261027;; Simpler replacement for SRFI-13's string-any1028(define (string-any criteria s)1029 (let ((end (string-length s)))1030 (let lp ((i 0))1031 (let ((c (string-ref s i))1032 (i1 (+ i 1)))1033 (if (= i1 end) (criteria c)1034 (or (criteria c)1035 (lp i1)))))))10361037(define (exec prog args)1038 ;; NOTE: We construct a command line for debugging purposes, but it1039 ;; does not 100% represent what gets executed.1040 (let ((cmdline (string-intersperse (map quotewrap (cons prog args)) " ")))1041 (when verbose1042 (print cmdline))1043 (unless dry-run1044 (let*-values (((pid) (process-run prog args))1045 ((pid success? exit-code) (process-wait pid)))1046 (when (or (not success?) (not (zero? exit-code)))1047 (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" exit-code cmdline)1048 (exit exit-code))))))10491050(define ($delete-file str)1051 (when verbose1052 (print "rm " str) )1053 (unless dry-run (delete-file str) ))10541055(define (create-win-manifest prg rcfname)1056 (when verbose (print "generating " rcfname))1057 (with-output-to-file rcfname1058 (lambda ()1059 (print #<#EOF10601 24 MOVEABLE PURE1061BEGIN1062 "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>\r\n"1063 "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">\r\n"1064 " <assemblyIdentity version=""1.0.0.0"" processorArchitecture=""*"" name=""#{prg}"" type=""win32""/>\r\n"1065 " <ms_asmv2:trustInfo xmlns:ms_asmv2=""urn:schemas-microsoft-com:asm.v2"">\r\n"1066 " <ms_asmv2:security>\r\n"1067 " <ms_asmv2:requestedPrivileges>\r\n"1068 " <ms_asmv2:requestedExecutionLevel level=""asInvoker"" uiAccess=""false""/>\r\n"1069 " </ms_asmv2:requestedPrivileges>\r\n"1070 " </ms_asmv2:security>\r\n"1071 " </ms_asmv2:trustInfo>\r\n"1072 "</assembly>\r\n"1073END1074EOF1075) ) ) )107610771078;;; Run it:10791080(run1081 (append1082 (string-split (or (get-environment-variable "CSC_OPTIONS") ""))1083 arguments))10841085)