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


(cond-expand 
 [(not unistd)
  (display "Sorry, can't run `csc' on this platform - `unistd' unit not available.\n")
  (exit 1) ]
 [else] )


;;; Parameters:

(define-constant translator "/usr/bin/chicken")
(define-constant compiler "gcc")
(define-constant linker "gcc")
(define-constant object-extension "o")
(define-constant link-output-flag "-o ")
(define-constant compile-output-flag "-o ")
(define-constant use-different-optimized-libs #f)

(define-constant default-translation-optimization-options '())
(define-constant default-compilation-optimization-options '("-g"))
(define-constant default-linking-optimization-options '())
(define-constant best-compilation-optimization-options (string-split "-O3 -fomit-frame-pointer -fstrict-aliasing -DHAVE_ALLOCA_H  "))
(define-constant best-linking-optimization-options '("-s"))

(define-constant simple-options
  '(-explicit-use -no-trace -no-warnings -optimize -usual-integrations -optimize-leaf-routines -unsafe
    -block -inline -disable-interrupts -fixnum-arithmetic -no-fancy-ports -no-winding-callcc -to-stdout
    -check-syntax -expand-only -hygienic -write-dependencies -case-sensitive -benchmark-mode
    -emit-debug-info -debug-calls -debug-loops -srfi-7 -strict -strict-srfi-0) )

(define-constant complex-options
  '(-debug -output-file -inline-limit -inline-passes -dependency-output -heap-size -nursery -stack-size
    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
    -feature -no-feature -debug-level -profile) )

(define-constant shortcuts
  '((|-H| "-hygienic")
    (-h "-help")
    (|-V| "-version")
    (|-O| "-optimize")
    (|-Ob| "-benchmark-mode")
    (-f "-fixnum-arithmetic")
    (-a "-case-sensitive")
    (|-U| "-usual-integrations")
    (-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 default-library-files '("-lchicken" "-lstuffed-chicken" "-lm"))
(define unsafe-library-files '("-luchicken" "-lustuffed-chicken" "-lm"))
(define library-files default-library-files)

(define optimized-library-files
  (if use-different-optimized-libs
      '("-lchicken-optimized" "-lstuffed-chicken-optimized" "-lm")
      default-library-files) )

(define translate-options '("-quiet"))
(define compile-options '("-c" "-I/usr/include"))
(define translation-optimization-options default-translation-optimization-options)
(define compilation-optimization-options default-compilation-optimization-options)
(define linking-optimization-options default-linking-optimization-options)
(define link-options '("-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)


;;; 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 FILENAME                 specifies target executable name
    -I PATHNAME
    -include-path PATHNAME      specifies alternative path for included files
    -to-stdout                  write compiler to stdout (implies -t)

  Language options:

    -a  -case-sensitive         preserve case of read symbols
    -H  -hygienic               use syntax-case macro package
    -feature SYMBOL             register feature identifier
    -no-feature SYMBOL          unregister feature identifier
    -strict                     disable non-standard macros
    -strict-srfi-0              disable non-standard macros except `cond-expand'

  Translation options:

    -x  -explicit-use           do not use units `library' and `eval' by default
    -database-size NUMBER       specifies size of analysis-database
    -w  -no-warnings            disable warnings
    -check-syntax               abort compilation after macro-expansion
    -expand-only                write macro-expanded source to file (implies -t)
    -E                          equivalent to `-expand-only -to-stdout'
    -write-dependencies         output include-file dependencies
    -dependency-output FILENAME destination for dependency output

  Debugging options:
    -d0 -d1 -d2 -d3 -d4 -debug-level NUMBER
                                set level of available debugging information
    -no-trace                   disable rudimentary debugging information
    -emit-debug-info            emit extended debugging information
    -debug-calls                emit extra code to track non-loop procedure calls
    -debug-loops                emit extra code to track all procedure calls
    -profile FILENAME           executable emits profiling information 

  Optimization options:

    -O  -optimize               enable optimizations
    -O1 -O2 -O3 -O4 -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
    -inline                     enable inlining
    -inline-limit NUMBER        maximum percentage of growth through inlining
    -inline-passes NUMBER       maximal number of inlining passes
    -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
    -no-fancy-ports             use only file- and std-ports
    -no-winding-callcc          use non-winding semantics for call/cc

  Configuration options:

    -heap-size NUMBER           specifies heap-size of compiled executable
    -nursery NUMBER  -stack-size NUMBER
		                specifies nursery size of compiled executable
    -extend FILENAME            load file before compilation commences
    -prelude EXPRESSION         add expression to front 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

  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

  Obscure options:

    -debug MODES                display debugging output for the given modes

  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 (pathname-strip-extension (last c-files))) ) ]
		 [else
		  (unless target-filename
		    (set! target-filename (pathname-strip-extension (last scheme-files))) )
		  (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) ]
	       [(-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)) ]
	       [(-k) (set! keep-files #t)]
	       [(-c) (set! compile-only #t)]
	       [(-t) (set! translate-only #t)]
	       [(|-E|)
		(set! translate-only #t)	
	        (set! to-stdout #t)
		(t-options "-expand-only" "-to-stdout") ]
	       [(-o)
		(check s rest)
		(let ([fn (car rest)])
		  (set! rest (cdr rest))
		  (set! target-filename fn) ) ]
	       [(|-O1|) (set! rest (cons* "-optimize-level" "1" rest))]
	       [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]
	       [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]
	       [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]
	       [(-d0) (set! rest (cons* "-debug-level" "0" rest))]
	       [(-d1) (set! rest (cons* "-debug-level" "1" rest))]
	       [(-d2) (set! rest (cons* "-debug-level" "2" rest))]
	       [(-d3) (set! rest (cons* "-debug-level" "3" rest))]
	       [(-d4) (set! rest (cons* "-debug-level" "4" rest))]
	       [(|-C|)
		(check s rest)
		(set! compile-options (append compile-options (list (car rest))))
		(set! rest (cdr rest)) ]
	       [(|-L|)
		(check s rest)
		(set! link-options (append link-options (list (car rest))))
		(set! rest (cdr rest)) ]
	       [else
		(when (memq s '(-unsafe -benchmark-mode))
		  (set! unsafe #t) 
		  (set! library-files unsafe-library-files) )
		(when (eq? s '-to-stdout) 
		  (set! to-stdout #t)
		  (set! translate-only #t) )
		(when (memq s '(-optimize -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)) )
		(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) )
			 (t-options arg n)
			 (set! rest (cdr rest)) ) ]
		      [(and (> (string-length arg) 2) (char=? #\: (string-ref arg 1)))
		       (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))]
			       [(string=? ext "c") (set! c-files (cons arg c-files))]
			       [(string=? ext object-extension) (set! object-files (cons arg object-files))]
			       [(or (string=? ext "a") (string=? ext "so")) 
				(set! library-files (cons arg 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)
		"c") ] )
       (unless (zero?
		(system* 
		 (string-concatenate 
		  (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-concatenate
		  (cons* compiler f (string-append compile-output-flag fo)
			 (map quote-option (append compile-options compilation-optimization-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 (append (reverse object-files) library-files)])
    (unless (zero?
	     (system*
	      (string-concatenate 
	       (cons* linker (string-append link-output-flag target-filename)
		      (append linking-optimization-options files link-options) )
	       " ") ) )
      (exit last-exit-code) )
    (unless keep-files (for-each delete-file* generated-object-files)) ) )


;;; Helper procedures:

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

(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 (print "rm " str))
  (delete-file str) )


;;; Run it:

(run (command-line-arguments))
