source: project/chicken/branches/release/csc.scm @ 6577

Last change on this file since 6577 was 6577, checked in by felix winkelmann, 12 years ago

merged changes from trunk (rev 6579)

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