source: project/chicken/trunk/csc.scm @ 13672

Last change on this file since 13672 was 13672, checked in by Kon Lovett, 11 years ago

Added 'parenthesis-synonyms' concept. Updated the unsafe inlines w/ more routines & better names.

File size: 33.9 KB
Line 
1;;;; csc.scm - Driver program for the CHICKEN compiler - felix -*- Scheme -*-
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     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 promote
15;     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 EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (block)
30  (uses data-structures ports srfi-1 srfi-13 utils files extras))
31
32(define-foreign-variable INSTALL_BIN_HOME c-string "C_INSTALL_BIN_HOME")
33(define-foreign-variable INSTALL_CC c-string "C_INSTALL_CC")
34(define-foreign-variable INSTALL_CXX c-string "C_INSTALL_CXX")
35(define-foreign-variable TARGET_CC c-string "C_TARGET_CC")
36(define-foreign-variable TARGET_CXX c-string "C_TARGET_CXX")
37(define-foreign-variable TARGET_CFLAGS c-string "C_TARGET_CFLAGS")
38(define-foreign-variable INSTALL_CFLAGS c-string "C_INSTALL_CFLAGS")
39(define-foreign-variable TARGET_LDFLAGS c-string "C_TARGET_LDFLAGS")
40(define-foreign-variable INSTALL_LDFLAGS c-string "C_INSTALL_LDFLAGS")
41(define-foreign-variable INSTALL_MORE_LIBS c-string "C_INSTALL_MORE_LIBS")
42(define-foreign-variable INSTALL_MORE_STATIC_LIBS c-string "C_INSTALL_MORE_STATIC_LIBS")
43(define-foreign-variable INSTALL_SHARE_HOME c-string "C_INSTALL_SHARE_HOME")
44(define-foreign-variable INSTALL_LIB_HOME c-string "C_INSTALL_LIB_HOME")
45(define-foreign-variable INSTALL_INCLUDE_HOME c-string "C_INSTALL_INCLUDE_HOME")
46(define-foreign-variable INSTALL_STATIC_LIB_HOME c-string "C_INSTALL_STATIC_LIB_HOME")
47(define-foreign-variable TARGET_MORE_LIBS c-string "C_TARGET_MORE_LIBS")
48(define-foreign-variable TARGET_MORE_STATIC_LIBS c-string "C_TARGET_MORE_STATIC_LIBS")
49(define-foreign-variable TARGET_BIN_HOME c-string "C_TARGET_BIN_HOME")
50(define-foreign-variable TARGET_SHARE_HOME c-string "C_TARGET_SHARE_HOME")
51(define-foreign-variable TARGET_LIB_HOME c-string "C_TARGET_LIB_HOME")
52(define-foreign-variable TARGET_INCLUDE_HOME c-string "C_TARGET_INCLUDE_HOME")
53(define-foreign-variable TARGET_STATIC_LIB_HOME c-string "C_TARGET_STATIC_LIB_HOME")
54(define-foreign-variable TARGET_RUN_LIB_HOME c-string "C_TARGET_RUN_LIB_HOME")
55(define-foreign-variable CHICKEN_PROGRAM c-string "C_CHICKEN_PROGRAM")
56(define-foreign-variable WINDOWS_SHELL bool "C_WINDOWS_SHELL")
57
58
59;;; Parameters:
60
61(define mingw (eq? (build-platform) 'mingw32))
62(define msvc (eq? (build-platform) 'msvc))
63(define osx (eq? (software-version) 'macosx))
64(define hpux-hppa (and (eq? (software-version) 'hpux)
65                       (eq? (machine-type) 'hppa)))
66
67(define (quit msg . args)
68  (fprintf (current-error-port) "csc: ~?~%" msg args)
69  (exit 64) )
70
71(define chicken-prefix (getenv "CHICKEN_PREFIX"))
72(define arguments (command-line-arguments))
73(define host-mode (member "-host" arguments))
74(define cross-chicken (##sys#fudge 39))
75
76(define (prefix str dir default)
77  (if chicken-prefix
78      (make-pathname (list chicken-prefix dir) str)
79      default) )
80
81(define (quotewrap str)
82  (qs (normalize-pathname str)))
83
84(define home
85  (quotewrap 
86   (prefix "" "share" (if host-mode INSTALL_SHARE_HOME TARGET_SHARE_HOME))))
87
88(define translator
89  (quotewrap 
90   (prefix "chicken" "bin"
91           (make-pathname
92            (if host-mode INSTALL_BIN_HOME TARGET_BIN_HOME)
93            CHICKEN_PROGRAM))))
94
95(define compiler (quotewrap (if host-mode INSTALL_CC TARGET_CC)))
96(define c++-compiler (quotewrap (if host-mode INSTALL_CXX TARGET_CXX)))
97(define linker (quotewrap (if msvc "link" (if host-mode INSTALL_CC TARGET_CC))))
98(define c++-linker (quotewrap (if msvc "link" (if host-mode INSTALL_CXX TARGET_CXX))))
99(define object-extension (if msvc "obj" "o"))
100(define library-extension (if msvc "lib" "a"))
101(define link-output-flag (if msvc "-out:" "-o "))
102(define executable-extension (if msvc "exe" ""))
103(define compile-output-flag (if msvc "-Fo" "-o "))
104(define nonstatic-compilation-options '())
105(define shared-library-extension ##sys#load-dynamic-extension)
106(define default-translation-optimization-options '())
107(define pic-options (if (or mingw msvc) '("-DPIC") '("-fPIC" "-DPIC")))
108(define windows-shell WINDOWS_SHELL)
109
110(define default-library (string-append
111                         (if msvc "libchicken-static." "libchicken.")
112                         library-extension))
113(define default-unsafe-library (string-append
114                                (if msvc "libuchicken-static." "libuchicken.")
115                                library-extension))
116
117(define cleanup-filename quotewrap)
118
119(define default-compilation-optimization-options (string-split (if host-mode INSTALL_CFLAGS TARGET_CFLAGS)))
120(define best-compilation-optimization-options default-compilation-optimization-options)
121(define default-linking-optimization-options (string-split (if host-mode INSTALL_LDFLAGS TARGET_LDFLAGS)))
122(define best-linking-optimization-options default-linking-optimization-options)
123
124(define-constant simple-options
125  '(-explicit-use -no-trace -no-warnings -no-usual-integrations -optimize-leaf-routines -unsafe
126    -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile
127    -check-syntax -case-insensitive -benchmark-mode -shared -compile-syntax -no-lambda-info
128    -lambda-lift -dynamic -disable-stack-overflow-checks -local
129    -emit-external-prototypes-first -inline -extension -release
130    -analyze-only -keep-shadowed-macros -inline-global) -ignore-repository)
131
132(define-constant complex-options
133  '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
134    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue 
135    -inline-limit -profile-name -disable-warning -emit-inline-file
136    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size 
137    -emit-import-library -static-extension))
138
139(define-constant shortcuts
140  '((-h "-help")
141    (-s "-shared")
142    (|-E| "-extension")
143    (|-P| "-check-syntax")
144    (|-V| "-version")
145    (|-Ob| "-benchmark-mode")
146    (-f "-fixnum-arithmetic")
147    (|-D| "-feature")
148    (-i "-case-insensitive")
149    (|-K| "-keyword-style")
150    (|-X| "-extend")
151    (|-N| "-no-usual-integrations")
152    (-x "-explicit-use")
153    (-u "-unsafe")
154    (-j "-emit-import-library")
155    (-n "-emit-inline-file")
156    (-b "-block") ) )
157
158(define short-options
159  (string->list "PHhsfiENxubvwAOeWkctg") )
160
161
162;;; Variables:
163
164(define scheme-files '())
165(define generated-scheme-files '())
166(define c-files '())
167(define generated-c-files '())
168(define object-files '())
169(define generated-object-files '())
170(define cpp-mode #f)
171(define objc-mode #f)
172(define embedded #f)
173(define inquiry-only #f)
174(define show-cflags #f)
175(define show-ldflags #f)
176(define show-libs #f)
177(define dry-run #f)
178
179(define extra-libraries
180  (if host-mode
181      INSTALL_MORE_STATIC_LIBS
182      TARGET_MORE_STATIC_LIBS))
183(define extra-shared-libraries 
184  (if host-mode 
185      INSTALL_MORE_LIBS
186      TARGET_MORE_LIBS))
187(define default-library-files 
188  (list
189   (quotewrap
190    (prefix default-library "lib"
191            (string-append
192             (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
193             (string-append "/" default-library)))) ))
194(define default-shared-library-files (if msvc
195                                         (list (string-append "libchicken." library-extension))
196                                         '("-lchicken")))
197(define unsafe-library-files
198  (list
199   (quotewrap 
200    (prefix default-unsafe-library "lib"
201            (string-append
202             (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
203             (string-append "/" default-unsafe-library)))) ))
204(define unsafe-shared-library-files (if msvc
205                                        (list (string-append "libuchicken." library-extension))
206                                        '("-luchicken")))
207(define gui-library-files default-library-files)
208(define gui-shared-library-files default-shared-library-files)
209(define library-files default-library-files)
210(define shared-library-files default-shared-library-files)
211
212(define translate-options '())
213
214(define include-dir
215  (let ((id (prefix "" "include" 
216                    (if host-mode INSTALL_INCLUDE_HOME TARGET_INCLUDE_HOME))))
217    (and (not (member id '("/usr/include" "")))
218         id) ) )
219
220(define compile-options '())
221(define builtin-compile-options
222  (if include-dir (list (conc "-I" (quotewrap include-dir))) '()))
223
224(define compile-only-flag "-c")
225(define translation-optimization-options default-translation-optimization-options)
226(define compilation-optimization-options default-compilation-optimization-options)
227(define linking-optimization-options default-linking-optimization-options)
228
229(define library-dir
230  (prefix "" "lib"
231         (if host-mode
232             INSTALL_LIB_HOME
233             TARGET_LIB_HOME)) )
234
235(define link-options '())
236(define builtin-link-options
237  (cond ((or osx hpux-hppa mingw)
238         (list (conc "-L" (quotewrap library-dir))))
239        (msvc
240         (list (conc "-LIBPATH:" (quotewrap library-dir))))
241        (else
242         (list
243          (conc "-L" (quotewrap library-dir))
244          (conc " -Wl,-R" (quotewrap (prefix "" "lib"
245                                             (if host-mode
246                                                 INSTALL_LIB_HOME
247                                                 TARGET_RUN_LIB_HOME)))) ) ) ) )
248
249(define target-filename #f)
250(define verbose #f)
251(define keep-files #f)
252(define translate-only #f)
253(define compile-only #f)
254(define to-stdout #f)
255(define shared #f)
256(define static #f)
257(define static-libs #f)
258(define static-extensions '())
259(define required-extensions '())
260(define gui #f)
261
262
263;;; Display usage information:
264
265(define (usage)
266  (display
267"Usage: csc FILENAME | OPTION ...
268
269  `csc' is a driver program for the CHICKEN compiler. Any Scheme, C or object
270  files and all libraries given on the command line are translated, compiled or
271  linked as needed.
272
273  General options:
274
275    -h  -help                   display this text and exit
276    -v                          show intermediate compilation stages
277    -v2  -verbose               display information about translation progress
278    -v3                         display information about all compilation stages
279    -V  -version                display Scheme compiler version and exit
280    -release                    display release number and exit
281
282  File and pathname options:
283
284    -o -output-file FILENAME    specifies target executable name
285    -I -include-path PATHNAME   specifies alternative path for included files
286    -to-stdout                  write compiler to stdout (implies -t)
287    -s -shared -dynamic         generate dynamically loadable shared object file
288
289  Language options:
290
291    -D  -DSYMBOL  -feature SYMBOL
292                                register feature identifier
293    -c++                        Compile via a C++ source file (.cpp)
294    -objc                       Compile via Objective-C source file (.m)
295
296  Syntax related options:
297
298    -i -case-insensitive        don't preserve case of read symbols   
299    -K -keyword-style STYLE     allow alternative keyword syntax (prefix, suffix or none)
300       -parenthesis-synonyms STYLE
301                                allow list delimiter synonyms (block or none)
302    -compile-syntax             macros are made available at run-time
303    -j -emit-import-library MODULE
304                                write compile-time module information into separate file
305
306  Translation options:
307
308    -x  -explicit-use           do not use units `library' and `eval' by default
309    -P  -check-syntax           stop compilation after macro-expansion
310    -A  -analyze-only           stop compilation after first analysis pass
311
312  Debugging options:
313
314    -w  -no-warnings            disable warnings
315    -disable-warning CLASS      disable specific class of warnings
316    -d0 -d1 -d2 -debug-level NUMBER
317                                set level of available debugging information
318    -no-trace                   disable rudimentary debugging information
319    -profile                    executable emits profiling information
320    -accumulate-profile         executable emits profiling information in append mode
321    -profile-name FILENAME      name of the generated profile information file
322
323  Optimization options:
324
325    -O -O1 -O2 -O3 -O4 -optimize-level NUMBER
326                                enable certain sets of optimization options
327    -optimize-leaf-routines     enable leaf routine optimization
328    -N  -no-usual-integrations  standard procedures may be redefined
329    -u  -unsafe                 disable safety checks
330    -local                      assume globals are only modified in current file
331    -b  -block                  enable block-compilation
332    -disable-interrupts         disable interrupts in compiled code
333    -f  -fixnum-arithmetic      assume all numbers are fixnums
334    -Ob  -benchmark-mode        equivalent to '-block -optimize-level 4
335                                 -debug-level 0 -fixnum-arithmetic -lambda-lift
336                                 -disable-interrupts -inline'
337    -lambda-lift                perform lambda-lifting
338    -unsafe-libraries           link with unsafe runtime system
339    -disable-stack-overflow-checks  disables detection of stack-overflows
340    -inline                     enable inlining
341    -inline-limit               set inlining threshold
342    -inline-global              enable cross-module inlining
343    -n -emit-inline-file FILENAME 
344                                generate file with globally inlinable procedures
345                                (implies -inline -local)
346
347  Configuration options:
348
349    -unit NAME                  compile file as a library unit
350    -uses NAME                  declare library unit as used.
351    -heap-size NUMBER           specifies heap-size of compiled executable
352    -heap-initial-size NUMBER   specifies heap-size at startup time
353    -heap-growth PERCENTAGE     specifies growth-rate of expanding heap
354    -heap-shrinkage PERCENTAGE  specifies shrink-rate of contracting heap
355    -nursery NUMBER  -stack-size NUMBER
356                                specifies nursery size of compiled executable
357    -X -extend FILENAME         load file before compilation commences
358    -prelude EXPRESSION         add expression to beginning of source file
359    -postlude EXPRESSION        add expression to end of source file
360    -prologue FILENAME          include file before main source file
361    -epilogue FILENAME          include file after main source file
362    -ignore-repository          do not refer to repository for extensions
363
364    -e  -embedded               compile as embedded (don't generate `main()')
365    -W  -windows                compile as Windows GUI application (MSVC only)
366    -R  -require-extension NAME require extension and import in compiled code
367    -E  -extension              compile as extension (dynamic or static)
368    -dll -library               compile multiple units into a dynamic library
369
370  Options to other passes:
371
372    -C OPTION                   pass option to C compiler
373    -L OPTION                   pass option to linker
374    -I<DIR>                     pass \"-I<DIR>\" to C compiler (add include path)
375    -L<DIR>                     pass \"-L<DIR>\" to linker (add library path)
376    -k                          keep intermediate files
377    -c                          stop after compilation to object files
378    -t                          stop after translation to C
379    -cc COMPILER                select other C compiler than the default one
380    -cxx COMPILER               select other C++ compiler than the default one
381    -ld COMPILER                select other linker than the default one
382    -lLIBNAME                   link with given library (`libLIBNAME' on UNIX,
383                                 `LIBNAME.lib' on Windows)                               
384    -static-libs                link with static CHICKEN libraries
385    -static                     generate completely statically linked executable
386    -static-extension NAME      link extension NAME statically (if available)
387    -F<DIR>                     pass \"-F<DIR>\" to C compiler (add framework
388                                 header path on Mac OS X)
389    -framework NAME             passed to linker on Mac OS X
390    -rpath PATHNAME             add directory to runtime library search path
391    -Wl,...                     pass linker options
392    -strip                      strip resulting binary
393
394  Inquiry options:
395
396    -home                       show home-directory (where support files go)
397    -cflags                     show required C-compiler flags and exit
398    -ldflags                    show required linker flags and exit
399    -libs                       show required libraries and exit
400    -cc-name                    show name of default C compiler used
401    -cxx-name                   show name of default C++ compiler used
402    -ld-name                    show name of default linker used
403    -dry-run                    just show commands executed, don't run them
404                                 (implies `-v')
405
406  Obscure options:
407
408    -debug MODES                display debugging output for the given modes
409    -compiler PATHNAME          use other compiler than default `chicken'
410    -disable-c-syntax-checks    disable syntax checks of C code fragments
411    -raw                        do not generate implicit init- and exit code                           
412    -emit-external-prototypes-first  emit protoypes for callbacks before foreign
413                                 declarations
414    -keep-shadowed-macros       do not remove shadowed macro
415    -host                       compile for host when configured for cross-compiling
416
417  Options can be collapsed if unambiguous, so
418
419    -vkfO
420
421  is the same as
422
423    -v -k -fixnum-arithmetic -optimize
424
425  The contents of the environment variable CSC_OPTIONS are implicitly
426  passed to every invocation of `csc'.
427"
428) )
429
430
431;;; Parse arguments:
432
433(define (run args)
434
435  (define (t-options . os)
436    (set! translate-options (append translate-options os)) )
437
438  (define (check o r . n)
439    (unless (>= (length r) (optional n 1))
440      (quit "not enough arguments to option `~A'" o) ) )
441
442  (define (shared-build lib)
443    (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))
444    (set! compile-options (append pic-options '("-DC_SHARED") compile-options))
445    (set! link-options
446      (cons (cond
447             (osx (if lib "-dynamiclib" "-bundle"))
448             (msvc "-dll")
449             (else "-shared")) link-options))
450    (set! shared #t) )
451
452  (let loop ([args args])
453    (cond [(null? args)
454           ;Builtin search directory options do not override explict options
455           (set! compile-options (append compile-options builtin-compile-options))
456           (set! link-options (append link-options builtin-link-options))
457           ;
458           (when inquiry-only
459             (when show-cflags (print* (compiler-options) #\space))
460             (when show-ldflags (print* (linker-options) #\space))
461             (when show-libs (print* (linker-libraries #t) #\space))
462             (newline)
463             (exit) )
464           #;(when (null? scheme-files)
465             (set! scheme-files c-files)
466             (set! c-files '()) )
467           (cond [(null? scheme-files)
468                  (when (and (null? c-files) (null? object-files))
469                    (quit "no source files specified") )
470                  (let ((f0 (last (if (null? c-files) object-files c-files))))
471                    (unless target-filename
472                      (set! target-filename 
473                        (if shared
474                            (pathname-replace-extension f0 shared-library-extension)
475                            (pathname-replace-extension f0 executable-extension) ) ) ) ) ]
476                 [else
477                  (when (and shared (not embedded))
478                    (set! translate-options (cons "-dynamic" translate-options)) )
479                  (unless target-filename
480                    (set! target-filename
481                      (if shared
482                          (pathname-replace-extension (first scheme-files) shared-library-extension)
483                          (pathname-replace-extension (first scheme-files) executable-extension) ) ) )
484                  (run-translation) ] )
485           (unless translate-only 
486             (run-compilation)
487             (unless compile-only
488               (when (member target-filename scheme-files)
489                 (printf "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"
490                         target-filename target-filename)
491                 (unless (zero? ($system (sprintf "~A ~A ~A" 
492                                                  (if *windows-shell* "move" "mv")
493                                                  (quotewrap target-filename)
494                                                  (quotewrap (string-append target-filename ".old")))))
495                   (exit last-exit-code) ) )
496               (run-linking)) ) ]
497          [else
498           (let* ([arg (car args)]
499                  [rest (cdr args)]
500                  [s (string->symbol arg)] )
501             (case s
502               [(-help --help)
503                (usage)
504                (exit) ]
505               [(-release)
506                (print (chicken-version))
507                (exit) ]
508               [(-version)
509                (system (sprintf translator " -version"))
510                (exit) ]
511               [(-c++) 
512                (set! cpp-mode #t)
513                (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]
514               [(-objc) 
515                (set! objc-mode #t) ]
516               [(-static) 
517                (set! translate-options (cons* "-feature" "chicken-compile-static" translate-options))
518                (set! static #t) ]
519               [(-static-libs) 
520                (set! translate-options (cons* "-feature" "chicken-compile-static" translate-options))
521                (set! static-libs #t) ]
522               [(-cflags)
523                (set! inquiry-only #t) 
524                (set! show-cflags #t) ]
525               [(-ldflags)
526                (set! inquiry-only #t)
527                (set! show-ldflags #t) ]
528               [(-cc-name) (print compiler) (exit 0)]
529               [(-cxx-name) (print c++-compiler) (exit 0)]
530               [(-ld-name) (print linker) (exit 0)]
531               [(-home) (print home) (exit 0)]
532               [(-libs)
533                (set! inquiry-only #t)
534                (set! show-libs #t) ]
535               [(-v)
536                (set! verbose #t) ]
537               [(-v2 -verbose)
538                (set! verbose #t)
539                (t-options "-verbose") ]
540               [(-w -no-warnings)
541                (set! compile-options (cons "-w" compile-options))
542                (t-options "-no-warnings") ]
543               [(-v3)
544                (set! verbose #t)
545                (t-options "-verbose")
546                (if (not msvc)
547                    (set! compile-options (cons* "-v" "-Q" compile-options)))
548                (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) ]
549               [(|-A| -analyze-only)
550                (set! translate-only #t)
551                (t-options "-analyze-only") ]
552               [(|-P| -check-syntax)
553                (set! translate-only #t)
554                (t-options "-check-syntax") ]
555               [(-k) (set! keep-files #t)]
556               [(-c) (set! compile-only #t)]
557               [(-t) (set! translate-only #t)]
558               [(-e -embedded)
559                (set! embedded #t)
560                (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]
561               [(-require-extension -R)
562                (check s rest)
563                (set! required-extensions (append required-extensions (list (car rest))))
564                (t-options "-require-extension" (car rest))
565                (set! rest (cdr rest)) ]
566               [(-static-extension)
567                (check s rest)
568                (set! static-extensions (append static-extensions (list (car rest))))
569                (t-options "-static-extension" (car rest))
570                (set! rest (cdr rest)) ]
571               [(-windows |-W|)
572                (set! gui #t)
573                (cond
574                 (mingw
575                  (set! link-options
576                    (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"
577                           link-options))
578                  (set! compile-options (cons "-DC_WINDOWS_GUI" compile-options)))
579                 (msvc
580                  (set! link-options
581                    (cons* "kernel32.lib" "user32.lib" "gdi32.lib" link-options))
582                  (set! compile-options (cons "-DC_WINDOWS_GUI" compile-options)))) ]
583               [(-framework)
584                (check s rest)
585                (when osx 
586                  (set! link-options (cons* "-framework" (car rest) link-options)) )
587                (set! rest (cdr rest)) ]
588               [(-o)
589                (check s rest)
590                (let ([fn (car rest)])
591                  (set! rest (cdr rest))
592                  (set! target-filename fn) ) ]
593               [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]
594               [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]
595               [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]
596               [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]
597               [(-d0) (set! rest (cons* "-debug-level" "0" rest))]
598               [(-d1) (set! rest (cons* "-debug-level" "1" rest))]
599               [(-d2) (set! rest (cons* "-debug-level" "2" rest))]
600               [(-dry-run) 
601                (set! verbose #t)
602                (set! dry-run #t)]
603               [(-s -shared -dynamic)
604                (shared-build #f) ]
605               [(-dll -library)
606                (shared-build #t) ]
607               [(-compiler)
608                (check s rest)
609                (set! translator (car rest))
610                (set! rest (cdr rest)) ]
611               [(-cc)
612                (check s rest)
613                (set! compiler (car rest))
614                (set! rest (cdr rest)) ]
615               [(-cxx)
616                (check s rest)
617                (set! c++-compiler (car rest))
618                (set! rest (cdr rest)) ]
619               [(-ld)
620                (check s rest)
621                (set! linker (car rest))
622                (set! rest (cdr rest)) ]
623               [(|-I|)
624                (check s rest)
625                (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]
626               [(|-C|)
627                (check s rest)
628                (set! compile-options (append compile-options (string-split (car rest))))
629                (set! rest (cdr rest)) ]
630               [(-strip)
631                (set! link-options (append link-options (list "-s")))]
632               [(|-L|)
633                (check s rest)
634                (set! link-options (append link-options (string-split (car rest))))
635                (set! rest (cdr rest)) ]
636               [(-unsafe-libraries)
637                (t-options arg)
638                (set! library-files unsafe-library-files)
639                (set! shared-library-files unsafe-shared-library-files) ]
640               [(-rpath)
641                (check s rest)
642                (when (eq? 'gnu (build-platform))
643                  (set! link-options (append link-options (list (string-append "-Wl,-R" (car rest)))))
644                  (set! rest (cdr rest)) ) ]
645               [(-host) #f]
646               [(-) 
647                (set! target-filename (make-pathname #f "a" executable-extension))
648                (set! scheme-files (append scheme-files '("-")))]
649               [else
650                (when (memq s '(-unsafe -benchmark-mode))
651                  (when (eq? s '-benchmark-mode)
652                    (set! library-files unsafe-library-files)
653                    (set! shared-library-files unsafe-shared-library-files) ) )
654                (when (eq? s '-to-stdout) 
655                  (set! to-stdout #t)
656                  (set! translate-only #t) )
657                (when (memq s '(-optimize-level -benchmark-mode))
658                  (set! compilation-optimization-options best-compilation-optimization-options)
659                  (set! linking-optimization-options best-linking-optimization-options) )
660                (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]
661                      [(memq s simple-options) (t-options arg)]
662                      [(memq s complex-options) 
663                       (check s rest)
664                       (let* ([n (car rest)]
665                              [ns (string->number n)] )
666                         (t-options arg n)
667                         (set! rest (cdr rest)) ) ]
668                      [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))
669                       (t-options arg) ]
670                      [(and (> (string-length arg) 1)
671                            (char=? #\- (string-ref arg 0)) )
672                       (cond [(char=? #\l (string-ref arg 1))
673                              (set! link-options (append link-options (list arg))) ]
674                             [(char=? #\L (string-ref arg 1))
675                              (set! link-options (append link-options (list arg))) ]
676                             [(char=? #\I (string-ref arg 1))
677                              (set! compile-options (append compile-options (list arg))) ]
678                             [(char=? #\D (string-ref arg 1))
679                              (t-options "-feature" (substring arg 2)) ]
680                             [(char=? #\F (string-ref arg 1))
681                              (when osx
682                                (set! compile-options (append compile-options (list arg))) ) ]
683                             [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))
684                              (set! link-options (append link-options (list arg))) ]
685                             [(> (string-length arg) 2)
686                              (let ([opts (cdr (string->list arg))])
687                                (if (null? (lset-difference char=? opts short-options))
688                                    (set! rest
689                                      (append (map (lambda (o) (string-append "-" (string o))) opts) rest) )
690                                    (quit "invalid option `~A'" arg) ) ) ]
691                             [else (quit "invalid option `~A'" s)] ) ]
692                      [(file-exists? arg)
693                       (let-values ([(dirs name ext) (decompose-pathname arg)])
694                         (cond [(not ext) (set! scheme-files (append scheme-files (list arg)))]
695                               [(member ext '("h" "c"))
696                                (set! c-files (append c-files (list arg))) ]
697                               [(member ext '("cpp" "C" "cc" "cxx" "hpp"))
698                                (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))
699                                (set! cpp-mode #t)
700                                (set! c-files (append c-files (list arg))) ]
701                               [(member ext '("m" "M" "mm"))
702                                (set! objc-mode #t)
703                                (set! c-files (append c-files (list arg))) ]
704                               [(or (string=? ext object-extension)
705                                    (string=? ext library-extension) )
706                                (set! object-files (append object-files (list arg))) ]
707                               [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]
708                      [else
709                       (let ([f2 (string-append arg ".scm")])
710                         (if (file-exists? f2)
711                             (set! rest (cons f2 rest))
712                             (quit "file `~A' does not exist" arg) ) ) ] ) ] )
713             (loop rest) ) ] ) ) )
714
715
716;;; Translate all Scheme files:
717
718(define (run-translation)
719  (for-each
720   (lambda (f)
721     (let ([fc (pathname-replace-extension
722                (if (= 1 (length scheme-files))
723                    target-filename
724                    f)
725                (cond (cpp-mode "cpp")
726                      (objc-mode "m")
727                      (else "c") ) ) ] )
728       (unless (zero?
729                ($system 
730                 (string-intersperse 
731                  (cons* translator (cleanup-filename f) 
732                         (append
733                          (if to-stdout 
734                              '("-to-stdout")
735                              `("-output-file" ,(cleanup-filename fc)) )
736                          (map quote-option (append translate-options translation-optimization-options)) ) )
737                  " ") ) )
738         (exit last-exit-code) )
739       (set! c-files (append (list fc) c-files))
740       (set! generated-c-files (append (list fc) generated-c-files))))
741   scheme-files)
742  (unless keep-files (for-each $delete-file generated-scheme-files)) )
743
744
745;;; Compile all C files:
746
747(define (run-compilation)
748  (let ((ofiles '()))
749    (for-each
750     (lambda (f)
751       (let ([fo (pathname-replace-extension f object-extension)])
752         (unless (zero?
753                  ($system
754                   (string-intersperse
755                    (list (cond (cpp-mode c++-compiler)
756                                (else compiler) )
757                          (cleanup-filename f)
758                          (string-append compile-output-flag (cleanup-filename fo)) 
759                          compile-only-flag
760                          (compiler-options) ) ) ) )
761           (exit last-exit-code) )
762         (set! generated-object-files (cons fo generated-object-files))
763         (set! ofiles (cons fo ofiles))))
764     c-files)
765    (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first
766    (unless keep-files (for-each $delete-file generated-c-files)) ) )
767
768(define (compiler-options)
769  (string-intersperse
770   (map quote-option
771        (append
772         (if (or static static-libs) '() nonstatic-compilation-options)
773         compilation-optimization-options
774         compile-options) ) ) )
775
776
777;;; Link object files and libraries:
778
779(define (run-linking)
780  (let ((files (map cleanup-filename
781                    (append object-files
782                            (nth-value 0 (static-extension-info)) ) ) )
783        (target (cleanup-filename target-filename)))
784    (unless (zero?
785             ($system
786              (string-intersperse 
787               (cons* (cond (cpp-mode c++-linker)
788                            (else linker) )
789                      (append
790                       files
791                       (list (string-append link-output-flag target)
792                             (linker-options)
793                             (linker-libraries #f) ) ) ) ) ) )
794      (exit last-exit-code) )
795    (when (and osx (or (not cross-chicken) host-mode))
796      (unless (zero? ($system 
797                      (string-append
798                       "install_name_tool -change libchicken.dylib "
799                       (quotewrap 
800                        (make-pathname
801                         (prefix "" "lib"
802                                 (if host-mode
803                                     INSTALL_LIB_HOME
804                                     TARGET_RUN_LIB_HOME))
805                         "libchicken.dylib") )
806                       " " 
807                       target) ) )
808        (exit last-exit-code) ) )
809    (unless keep-files (for-each $delete-file generated-object-files)) ) )
810
811(define (static-extension-info)
812  (let ((rpath (repository-path)))
813    (if (and rpath (pair? static-extensions))
814        (let loop ((exts static-extensions) (libs '()) (opts '()))
815          (if (null? exts)
816              (values (reverse libs) (reverse opts))
817              (let ((info (extension-information (car exts))))
818                (if info
819                    (let ((a (assq 'static info)) 
820                          (o (assq 'static-options info)) )
821                      (loop (cdr exts) 
822                        (if a (cons (make-pathname rpath (cadr a)) libs) libs)
823                        (if o (cons (cadr o) opts) opts) ) ) 
824                    (loop (cdr exts) libs opts)) ) ) )
825        (values '() '()) ) ) )
826
827(define (linker-options)
828  (string-append
829   (string-intersperse
830    (append linking-optimization-options link-options
831            (nth-value 1 (static-extension-info)) ) )
832   (if (and static (not mingw) (not msvc) (not osx)) " -static" "") ) )
833
834(define (linker-libraries #!optional staticexts)
835  (string-intersperse
836   (append
837    (if staticexts (nth-value 0 (static-extension-info)) '())
838    (if (or static static-libs)
839        (if gui gui-library-files library-files)
840        (if gui gui-shared-library-files shared-library-files))
841    (if (or static static-libs)
842        (list extra-libraries)
843        (list extra-shared-libraries)))))
844
845
846;;; Helper procedures:
847
848(define-constant +hairy-chars+ '(#\\ #\#))
849
850(define (cleanup s)
851  (let* ((q #f)
852         (s (list->string
853             (let fold ([s (string->list s)])
854               (if (null? s) 
855                   '()
856                   (let ([c (car s)])
857                     (cond ((memq c +hairy-chars+) (cons* #\\ c (fold (cdr s))))
858                           (else
859                            (when (char-whitespace? c) (set! q #t))
860                            (cons c (fold (cdr s))) ) ) ) ) ) ) ) )
861    (if q 
862        (string-append "\"" (string-translate* s '(("\"" . "\\\""))) "\"")
863        s) ) )
864
865(define (quote-option x)
866  (if (string-any (lambda (c)
867                    (or (char-whitespace? c) (memq c +hairy-chars+)) )
868                  x)
869      (cleanup x)
870      x) )
871
872(define last-exit-code #f)
873
874(define ($system str)
875  (when verbose (print str))
876  (let ((str (if windows-shell
877                 (string-append "\"" str "\"")
878                 str)))
879    (set! last-exit-code
880      (if dry-run 
881          0
882          (system str)))
883    (unless (zero? last-exit-code)
884      (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" last-exit-code str) )
885    last-exit-code))
886
887(define ($delete-file str)
888  (when verbose 
889    (print "rm " str) )
890  (unless dry-run (delete-file str) ))
891
892
893;;; Run it:
894
895(run (append (string-split (or (getenv "CSC_OPTIONS") "")) arguments))
Note: See TracBrowser for help on using the repository browser.