;;;; chicken-crunch.scm
;
; Copyright (c) 2007-2009, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany


(module chicken-crunch (main)
  
(import scheme chicken)

(use files srfi-1 matchable data-structures extras)
(use crunch-expander crunch-compiler)


(define *c++* "c++")

(crunch-expand 
 '(define-syntax crunch:cond-expand-feature
    (syntax-rules (crunch-standalone)
      ((_ crunch-standalone kt kf) kt)
      ((_ x kt kf) kf))))

(define (usage #!optional (code 0))
  (print #<<EOF
usage: chicken-crunch OPTION | FILENAME ...

  -h            show this message
  -o FILENAME   set output filename
  -d            enable debug output
  -dd           enable more debug output
  -ddd          enable massive debug output
  -cc CC        select C++ compiler (default: "c++")
  -expand       only show code after expansion
  -entry NAME   set entry-point procedure
  -translate    only generate C++, don't compile

  All other options (arguments beginning with "-") are passed to
  the C++ compiler. FILENAME may be "-", which reads source code
  from stdin.
EOF
) ;|#
  (exit code) )

(define (option? s)
  (and (> (string-length s) 1) (char=? #\- (string-ref s 0))))

(define (main args)
  (let ((in #f)
	(out #f)
	(xonly #f)
	(tonly #f)
	(debug #f)
	(entry #f)
	(copts '()))
    (let loop ((args args))
      (match args
	(() 
	 (unless in (error "no input file"))
	 (let ((cfile (pathname-replace-extension 
		       (or (if (string=? in "-") "a" in)
			   out)
		       "cpp")))
	   (call-with-output-file cfile
	     (lambda (outfile)
	       (let ((code `(begin 
			      ,@(read-file
				 (if (string=? "-" in)
				     (current-input-port) 
				     in)))))
		 (cond (xonly
			(pp (crunch-expand code))
			(exit 0) )
		       (else
			(let-values (((f exports) 
				      (crunch-compile 
				       code
				       outfile 
				       entry-point: entry
				       debug: debug)))
			  (unless entry
			    (begin
			      (newline outfile)
			      (fprintf outfile "int main(int argc, char *argv[])\n")
			      (fprintf outfile "{\n")
			      (fprintf outfile "  C_main_argc = argc;\n")
			      (fprintf outfile "  C_main_argv = argv;\n")
			      (fprintf outfile "  ~a(); return ~a;\n"
				       f (let ((a (assq 'main exports)))
					   (if a
					       (conc (cadr a) "()")
					       "0")))
			      (fprintf outfile "}\n") ) ) ) ) ) ) ))
	   (if tonly
	       0
	       (let ((ccmd (string-intersperse (cons* *c++* cfile (reverse copts)))))
		 (when debug (print "  " ccmd))
		 (if (zero? (system ccmd))
		     0
		     1)))))
        (((or "-h" "-help" "--help") . _) (usage))
	(("-o" fname . more)
	 (set! out fname)
	 (set! copts (cons* fname "-o" copts))
	 (loop more))
	(("-d" . more)
	 (set! debug 1)
	 (loop more) )
	(("-dd" . more)
	 (set! debug 2)
	 (set! copts (cons "-Q -v" copts))
	 (loop more) )
	(("-ddd" . more)
	 (set! debug 3)
	 (set! copts (cons "-Q -v" copts))
	 (loop more) )
	(("-cc" cc . more)
	 (set! *c++* cc)
	 (loop more) )
	(("-expand" . more)
	 (set! xonly #t)
	 (loop more) )
	(("-translate" . more)
	 (set! tonly #t)
	 (loop more) )
	(("-entry" name . more)
	 (set! entry (string->symbol name))
	 (loop more) )
	(((? option? o) . more)
	 (set! copts (cons o copts)) 
	 (loop more))
	((fname . more)
	 (set! in fname)
	 (loop more) ) ) ) ) )

(exit (main (command-line-arguments)))

)