#! /usr/bin/csi -script
;;;; csc.scm - Driver program for the CHICKEN compiler - felix -*- Scheme -*-


;;; Parameters:

(define win (eq? (build-platform) 'msvc))
(define cygwin (eq? (build-platform) 'cygwin))
(define osx (eq? (software-version) 'macosx))

(define (homize str) (make-pathname home str))
(define home (or (getenv "CHICKEN_HOME") ""))

(if win
    (begin
      (define translator (homize "chicken"))
      (define compiler "cl")
      (define c++-compiler "cl")
      (define linker "link")
      (define c++-linker "link")
      (define object-extension "obj")
      (define library-extension "lib")
      (define link-output-flag "/out:")
      (define compile-output-flag "/Fo")
      (define executable-extension "exe")
      (define shared-library-extension "dll")
      (define nonstatic-compilation-options '("/DPIC")) )
    (begin
      (define translator "/usr/bin/chicken")
      (define compiler "i586-alt-linux-gcc")
      (define c++-compiler "i586-alt-linux-g++")
      (define linker "i586-alt-linux-gcc")
      (define c++-linker "i586-alt-linux-g++")
      (define object-extension "o")
      (define library-extension "a")
      (define link-output-flag "-o ")
      (define executable-extension "")
      (define compile-output-flag "-o ")
      (define nonstatic-compilation-options '())
      (define shared-library-extension (if cygwin "dll" "so")) ) )

(define default-translation-optimization-options '())

(if win
    (begin
      (define (cleanup-filename s) (string-translate s "/" "\\")) ; we need this to please the MSVC tools
      (define default-compilation-optimization-options '("/nologo"))
      (define default-linking-optimization-options '("/nologo"))
      (define best-linking-optimization-options '("/nologo"))
      (define best-compilation-optimization-options '("/O2" "/nologo")) )
    (begin
      (define (cleanup-filename s) s)
      (define default-compilation-optimization-options '("-g"))
      (define default-linking-optimization-options '())
      (define best-compilation-optimization-options (string-split #<<EOF
-pipe -Wall -O2 -march=i586 -mcpu=i686 -DC_STACK_GROWS_DOWNWARD=1 -DC_INSTALL_LIB_HOME="/usr/lib/chicken" -DC_USE_C_DEFAULTS
EOF
) )
      (define best-linking-optimization-options '()) ) )

(define-constant simple-options
  '(-explicit-use -no-trace -no-warnings -usual-integrations -optimize-leaf-routines -unsafe
    -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile
    -check-syntax -hygienic -case-insensitive -benchmark-mode -shared -compile-time-macros-only
    -srfi-7 -strict -strict-srfi-0 -lambda-lift -strict-letrec -dynamic
    -hygienic-at-run-time -analyze-only -ffi -r5rs) )

(define-constant complex-options
  '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue -require-for-syntax
    -feature -no-feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size
    -compress-literals -visit -ffi-define -ffi-include-path) )

(define-constant shortcuts
  '((|-H| "-hygienic")
    (-h "-help")
    (-s "-shared")
    (|-V| "-version")
    (|-Ob| "-benchmark-mode")
    (-f "-fixnum-arithmetic")
    (|-D| "-feature")
    (-i "-case-insensitive")
    (|-R| "-require-for-syntax")
    (|-K| "-keyword-style")
    (|-X| "-extend")
    (|-U| "-usual-integrations")
    (|-H2| "-hygienic -hygienic-at-run-time")
    (-x "-explicit-use")
    (-u "-unsafe")
    (-b "-block") ) )


;;; Variables:

(define scheme-files '())
(define c-files '())
(define generated-c-files '())
(define object-files '())
(define generated-object-files '())
(define cpp-mode #f)

(if win
    (begin
      (define extra-libraries "")
      (define extra-shared-libraries "")
      (define default-library-files
	(map homize '("libstuffed-chicken-static.lib" "libsrfi-chicken-static.lib" "libchicken-static.lib")))
      (define default-shared-library-files
	(map homize '("libchicken.lib" "libsrfi-chicken.lib" "libstuffed-chicken.lib")))
      (define unsafe-library-files
	(map homize '("libustuffed-chicken-static.lib" "libusrfi-chicken-static.lib" "libuchicken-static.lib")))
      (define unsafe-shared-library-files
	(map homize '("libuchicken.lib" "libusrfi-chicken.lib" "libustuffed-chicken.lib")))
      (define gui-library-files
	(map homize '("libstuffed-chicken-static.lib" "libsrfi-chicken-static.lib" "libchicken-gui-static.lib")))
      (define gui-shared-library-files
	(map homize '("libchicken-gui.lib" "libsrfi-chicken-gui.lib" "libstuffed-chicken-gui.lib"))) )
    (begin
      (define extra-libraries " -ldl -lm")
      (define extra-shared-libraries " -ldl -lm  -ldl")
      (define default-library-files '("/usr/lib/libstuffed-chicken.a" "/usr/lib/libsrfi-chicken.a" "/usr/lib/libchicken.a"))
      (define default-shared-library-files '("-lchicken" "-lsrfi-chicken" "-lstuffed-chicken"))
      (define unsafe-library-files '("/usr/lib/libustuffed-chicken.a" "/usr/lib/libusrfi-chicken.a" "/usr/lib/libuchicken.a"))
      (define unsafe-shared-library-files '("-luchicken" "-lusrfi-chicken" "-lustuffed-chicken"))
      (define gui-library-files default-library-files)
      (define gui-shared-library-files default-shared-library-files) ) )

(define library-files default-library-files)
(define shared-library-files default-shared-library-files)

(define optimized-library-files default-library-files)
(define optimized-shared-library-files default-shared-library-files)

(define translate-options '("-quiet"))

(define include-dir
  (let ([id "/usr/include"])
    (and (not (member id '("/usr/include" "/usr/local/include" "")))
	 id) ) )

(if win
    (define compile-options '("/c" "/I/usr/share/chicken" "/DC_NO_PIC_NO_DLL"))
    (define compile-options (cons* "-c" "-DC_NO_PIC_NO_DLL" (if include-dir (list "-I" include-dir) '()))) )

(define translation-optimization-options default-translation-optimization-options)
(define compilation-optimization-options default-compilation-optimization-options)
(define linking-optimization-options default-linking-optimization-options)

(if win
    (define link-options '())
    (define link-options 
      (if (eq? 'netbsd (software-version))
	  '("-Wl,-R/usr/lib  -L/usr/lib")
	  '("-L/usr/lib") ) ) )

(define target-filename #f)
(define verbose #f)
(define keep-files #f)
(define translate-only #f)
(define compile-only #f)
(define unsafe #f)
(define to-stdout #f)
(define shared #f)
(define static #f)
(define slibpath (getenv "SCHEME_LIBRARY_PATH"))
(define gui #f)
(define ffi #f)


;;; Display usage information:

(define (usage0)
  (display #<<EOF
Usage: csc FILENAME|OPTION ...

  Enter `csc -help' for more information

EOF
) )

(define (usage)
  (display #<<EOF
Usage: csc FILENAME|OPTION ...

  `csc' is a driver program for the CHICKEN compiler. Any Scheme or
  C files given on the command line are translated and compiled by 
  the host system's C compiler.

  General options:

    -h  -help                   display this text and exit
    -v                          show intermediate compilation stages
    -v2  -verbose               display information about translation progress
    -v3                         display information about all compilation stages
    -V  -version                display Scheme compiler version and exit

  File and pathname options:

    -o -output-file FILENAME    specifies target executable name
    -I -include-path PATHNAME   specifies alternative path for included files
    -to-stdout                  write compiler to stdout (implies -t)
    -s -shared -dynamic         generate dynamically loadable shared object file
    -static                     generate statically linked executable

  Language options:

    -D  -feature SYMBOL         register feature identifier
    -no-feature SYMBOL          unregister feature identifier
    -srfi-7                     process source file as SRFI-7 configuration
    -ffi-define SYMBOL          define preprocessor macro for ``easy'' FFI parser
    -ffi-include-path PATH      set include path for ``easy'' FFI parser
    -slib                       enable SLIB support (needs additional files)
    -c++                        Compile via a C++ source file
    -ffi                        compile C/C++ code and generate Scheme bindings
    -r5rs                       equivalent to `-hygienic -strict'

  Syntax related options:

    -i -case-insensitive        don't preserve case of read symbols    
    -H -hygienic                use syntax-case macro package
    -K -keyword-style STYLE     allow alternative keyword syntax (prefix or suffix)
    -strict                     disable non-standard macros and symbolsyntax
    -strict-srfi-0              disable non-standard macros except `cond-expand'
    -strict-reader              disable non-standard read syntax
    -strict-letrec              enable fully R5RS compliant `letrec'
    -compile-time-macros-only   low-level macros are not made available at run-time
    -hygienic-at-run-time       enable hygienic macros at run-time
    -H2                         identical to "-hygienic -hygienic-at-runtime"
    -visit FILENAME             reads and macroexpands source file FILENAME
    -R -require-for-syntax NAME load extension before compilation

  Translation options:

    -x  -explicit-use           do not use units `library' and `eval' by default
    -check-syntax               stop compilation after macro-expansion
    -A -analyze-only            stop compilation after first analysis pass

  Debugging options:

    -w  -no-warnings            disable warnings
    -d0 -d1 -debug-level NUMBER
                                set level of available debugging information
    -no-trace                   disable rudimentary debugging information
    -profile                    executable emits profiling information 

  Optimization options:

    -O -O1 -O2 -O3 -optimize-level NUMBER
			        enable certain sets of optimization options
    -optimize-leaf-routines     enable leaf routine optimization
    -U  -usual-integrations     assume standard procedures are not redefined
    -u  -unsafe                 disable safety checks
    -b  -block                  enable block-compilation
    -disable-interrupts         disable interrupts in compiled code
    -f  -fixnum-arithmetic      assume all numbers are fixnums
    -Ob  -benchmark-mode        fixnum mode, no interrupts and opt.-level 3
    -lambda-lift                perform lambda-lifting

  Configuration options:

    -unit NAME                  compile file as a library unit
    -uses NAME                  declare library unit as used.
    -heap-size NUMBER           specifies heap-size of compiled executable
    -heap-initial-size NUMBER   specifies heap-size at startup time
    -heap-growth PERCENTAGE     specifies growth-rate of expanding heap
    -heap-shrinkage PERCENTAGE  specifies shrink-rate of contracting heap
    -nursery NUMBER  -stack-size NUMBER
		                specifies nursery size of compiled executable
    -X -extend FILENAME         load file before compilation commences
    -prelude EXPRESSION         add expression to beginning of source file
    -postlude EXPRESSION        add expression to end of source file
    -prologue FILENAME          include file before main source file
    -epilogue FILENAME          include file after main source file

    -e  -embedded               compile as embedded (don't generate `main()')
    -windows                    compile as Windows GUI application (MSVC only)

  Options to other passes:

    -C OPTION                   pass option to C compiler
    -L OPTION                   pass option to linker
    -k                          keep intermediate files
    -c                          stop after compilation to object files
    -t                          stop after translation to C
    -cc COMPILER                select other C compiler than the default one
    -ld COMPILER                select other linker than the default one

  Obscure options:

    -debug MODES                display debugging output for the given modes
    -compiler PATHNAME          use other compiler than `/usr/bin/chicken'
    -compress-literals NUMBER   compile literals above threshold as strings

  Options can be collapsed if unambiguous, so

    -vkfO

  is the same as

    -v -k -fixnum-arithmetic -optimize

EOF
) )


(define (quit msg . args)
  (fprintf (current-error-port) "csc: ~?~%" msg args)
  (exit 64) )


;;; Parse arguments:

(define (run args)

  (define (t-options . os)
    (set! translate-options (append translate-options os)) )

  (define (check o r . n)
    (unless (>= (length r) (:optional n 1))
      (quit "not enough arguments to option `~A'" o) ) )

  (let loop ([args args])
    (cond [(null? args)
	   (cond [(null? scheme-files)
		  (when (null? c-files)
		    (usage0)
		    (exit) )
		  (unless target-filename
		    (set! target-filename 
		      (if shared
			  (pathname-replace-extension (last c-files) shared-library-extension)
			  (pathname-replace-extension (last c-files) executable-extension) ) ) ) ]
		 [else
		  (unless target-filename
		    (set! target-filename
		      (if shared
			  (pathname-replace-extension (last scheme-files) shared-library-extension)
			  (pathname-replace-extension (last scheme-files) executable-extension) ) ) )
		  (run-translation) ] )
	   (unless translate-only 
	     (run-compilation)
	     (unless compile-only
	       (when (member target-filename scheme-files)
		 (printf "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"
			 target-filename target-filename)
		 (unless (zero? (system* (sprintf "mv ~A ~A.old" target-filename target-filename)))
		   (exit last-exit-code) ) )
	       (run-linking)) ) ]
	  [else
	   (let* ([arg (car args)]
		  [rest (cdr args)]
		  [s (string->symbol arg)] )
	     (case s
	       [(-help)
		(usage)
		(exit) ]
	       [(-version)
		(system (sprintf translator " -version"))
		(exit) ]
	       [(-c++) (set! cpp-mode #t)]
	       [(-slib)
		(unless slibpath
		  (quit "you need to set the SCHEME_LIBRARY_PATH environment variable") )
		(t-options "-extend" (make-pathname slibpath "chicken-slib" shared-library-extension)
			   "-prologue" (make-pathname slibpath "chicken-slib-prologue.scm") ) ]
	       [(-static) 
		(set! static #t) ]
	       [(-v)
		(set! verbose #t) ]
	       [(-v2 -verbose)
		(set! verbose #t)
		(t-options "-verbose") ]
	       [(-w -no-warnings)
		(set! compile-options (cons "-w" compile-options))
		(t-options "-no-warnings") ]
	       [(-v3)
		(set! verbose #t)
		(t-options "-verbose")
		(set! compile-options (cons "-v" compile-options))
		(set! link-options (cons "-v" link-options)) ]
	       [(|-A| -analyze-only)
		(set! translate-only #t)
		(t-options "-analyze-only") ]
	       [(|-H2|) (set! rest (cons* "-hygienic" "-hygienic-at-run-time" rest))]
	       [(-k) (set! keep-files #t)]
	       [(-c) (set! compile-only #t)]
	       [(-t) (set! translate-only #t)]
	       [(-e -embedded)
		(set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]
	       [(-windows)
		(set! gui #t)
		(set! compile-options (cons "-DC_WINDOWS_GUI" compile-options)) ]
	       [(-o)
		(check s rest)
		(let ([fn (car rest)])
		  (set! rest (cdr rest))
		  (set! target-filename fn) ) ]
	       [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]
	       [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]
	       [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]
	       [(-d0) (set! rest (cons* "-debug-level" "0" rest))]
	       [(-d1) (set! rest (cons* "-debug-level" "1" rest))]
	       [(-ffi)
		(t-options "-ffi")
		(set! scheme-files c-files)
		(set! c-files '())
		(set! ffi #t) ]
	       [(-s -shared -dynamic)
		(set! translate-options (cons* "-feature" "chicken-compile-shared" "-dynamic" translate-options))
		(if win
		    (begin
		      (set! compile-options (cons* "/DPIC" "/DC_SHARED" compile-options)) 
		      (set! link-options (cons* "/dll" link-options)))
		    (begin
		      (set! compile-options (cons* "-fPIC" "-DPIC" "-DC_SHARED" compile-options)) 
		      (set! link-options
			(cons* "-fPIC" (if osx "-bundle" "-shared") link-options))))
		(set! shared #t) ]
	       [(-compiler)
		(check s rest)
		(set! translator (car rest))
		(set! rest (cdr rest)) ]
	       [(-cc)
		(check s rest)
		(set! compiler (car rest))
		(set! rest (cdr rest)) ]
	       [(-ld)
		(check s rest)
		(set! linker (car rest))
		(set! rest (cdr rest)) ]
	       [(|-I|)
		(check s rest)
		(set! rest (cons* "-include-path" (car rest) (cdr rest))) ]
	       [(|-C|)
		(check s rest)
		(set! compile-options (append compile-options (string-split (car rest))))
		(set! rest (cdr rest)) ]
	       [(|-L|)
		(check s rest)
		(set! link-options (append link-options (string-split (car rest))))
		(set! rest (cdr rest)) ]
	       [else
		(when (memq s '(-unsafe -benchmark-mode))
		  (set! unsafe #t) 
		  (set! library-files unsafe-library-files)
		  (set! shared-library-files unsafe-shared-library-files) )
		(when (eq? s '-to-stdout) 
		  (set! to-stdout #t)
		  (set! translate-only #t) )
		(when (memq s '(-optimize-level -benchmark-mode))
		  (set! compilation-optimization-options best-compilation-optimization-options)
		  (set! linking-optimization-options best-linking-optimization-options)
		  (unless unsafe 
		    (set! library-files optimized-library-files)
		    (set! shared-library-files optimized-shared-library-files)) )
		(cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]
		      [(memq s simple-options) (t-options arg)]
		      [(memq s complex-options) 
		       (check s rest)
		       (let* ([n (car rest)]
			      [ns (string->number n)] )
			 (when (and (eq? '-optimize-level s) (number? ns) (>= ns 3))
			   (set! unsafe #t) 
			   (set! library-files unsafe-library-files)
			   (set! shared-library-files unsafe-shared-library-files) )
			 (t-options arg n)
			 (set! rest (cdr rest)) ) ]
		      [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))
		       (t-options arg) ]
		      [(and (> (string-length arg) 1)
			    (char=? #\- (string-ref arg 0)) )
		       (if (> (string-length arg) 2)
			   (set! rest (append (map (lambda (o) (string-append "-" (string o))) (cdr (string->list arg))) rest))
			   (quit "invalid option `~A'" s) ) ]
		      [(file-exists? arg)
		       (let-values ([(dirs name ext) (decompose-pathname arg)])
			 (cond [(not ext) (set! scheme-files (cons arg scheme-files))]
			       [(or (string=? ext "c") (string=? ext "h"))
				(if ffi
				    (set! scheme-files (cons arg scheme-files))
				    (set! c-files (cons arg c-files)) ) ]
			       [(member ext '("cpp" "C" "cc" "cxx"))
				(set! cpp-mode #t)
				(if ffi
				    (set! scheme-files (cons arg scheme-files))
				    (set! c-files (cons arg c-files)) ) ]
			       [(or (string=? ext object-extension)
				    (string=? ext library-extension) )
				(set! object-files (cons arg object-files)) ]
			       [(or (string=? ext "a") (string=? ext shared-library-extension)) 
				(set! library-files (cons arg library-files)) 
				(set! shared-library-files (cons arg shared-library-files))]
			       [else (set! scheme-files (cons arg scheme-files))] ) ) ]
		      [else
		       (let ([f2 (string-append arg ".scm")])
			 (if (file-exists? f2)
			     (set! rest (cons f2 rest))
			     (quit "file `~A' does not exist" arg) ) ) ] ) ] )
	     (loop rest) ) ] ) ) )


;;; Translate all Scheme files:

(define (run-translation)
  (for-each
   (lambda (f)
     (let ([fc (pathname-replace-extension
		(if (= 1 (length scheme-files))
		    target-filename
		    f)
		(if cpp-mode "cpp" "c") ) ] )
       (unless (zero?
		(system* 
		 (string-intersperse 
		  (cons* translator f 
			 (append 
			  (if to-stdout 
			      '("-to-stdout")
			      `("-output-file" ,fc) )
			  (map quote-option (append translate-options translation-optimization-options)) ) )
		  " ") ) )
	 (exit last-exit-code) )
       (set! c-files (cons fc c-files))
       (set! generated-c-files (cons fc generated-c-files)) ) )
   (reverse scheme-files) ) )


;;; Compile all C files:

(define (run-compilation)
  (for-each
   (lambda (f)
     (let ([fo (pathname-replace-extension f object-extension)])
       (unless (zero?
		(system*
		 (string-intersperse
		  (cons* (if cpp-mode c++-compiler compiler)
			 (cleanup-filename f)
			 (string-append compile-output-flag (cleanup-filename fo))
			 (map quote-option
			      (append
			       (if static '() nonstatic-compilation-options)
			       compilation-optimization-options
			       compile-options)) ) 
		  " ") ) )
	 (exit last-exit-code) )
       (set! generated-object-files (cons fo generated-object-files))
       (set! object-files (cons fo object-files)) ) )
   (reverse c-files) )
  (unless keep-files (for-each delete-file* generated-c-files)) )


;;; Link object files and libraries:

(define (run-linking)
  (let ([files (map cleanup-filename
		    (append (reverse object-files)
			    (if static
				(if gui gui-library-files library-files)
				(if gui gui-shared-library-files shared-library-files) ) ) ) ] )
    (unless (zero?
	     (system*
	      (string-append
	       (string-intersperse 
		(cons* (if cpp-mode c++-linker linker)
		       (string-append link-output-flag (cleanup-filename target-filename))
		       (append linking-optimization-options files link-options) )
		" ")
	       (if static extra-libraries extra-shared-libraries) ) ) )
      (exit last-exit-code) )
    (when (and win (not static) (not shared))
      (delete-file* (pathname-replace-extension target-filename "exp"))
      (delete-file* (pathname-replace-extension target-filename "lib")) )
    (unless keep-files (for-each delete-file* generated-object-files)) ) )


;;; Helper procedures:

(define (quote-option x)
  (if (any (lambda (c)
	     (and (not (memq c '(#\- #\/ #\. #\: #\= #\_)))
		  (not (char-alphabetic? c))
		  (not (char-numeric? c)) ) )
	   (string->list x) )
      (string-append "\"" (cleanup x) "\"")
      x) )

(define (cleanup s)
  (list->string
   (let fold ([s (string->list s)])
     (if (null? s) 
	 '()
	 (let ([c (car s)])
	   (if (memq c '(#\" #\' #\\))
	       (cons* #\\ c (fold (cdr s)))
	       (cons c (fold (cdr s))) ) ) ) ) ) )

(define last-exit-code #f)

(define (system* str)
  (when verbose (print str))
  (set! last-exit-code (system str))
  (unless (zero? last-exit-code)
    (printf "*** Shell command terminated with exit status ~S: ~A~%" last-exit-code str) )
  last-exit-code)

(define (delete-file* str)
  (when verbose 
    (if win
	(print "del " str) 
	(print "rm " str) ) )
  (delete-file str) )


;;; Run it:

(run (command-line-arguments))
