;;;; driver.scm - compiler-invocation


(define dropped '())
(define defined '())
(define assigned '())
(define referenced '())
(define undefined '())
(define used-sections '())
(define default-xref-mode #f)


(define (spock-help)
  (display "(spock OPTION | FILENAME-OR-PORT ...)\n\n")
  (display "  Available options:\n\n")
  (display "  'source              show source forms\n")
  (display "  'expand              show forms after macro-expansion\n")
  (display "  'canonicalized       show forms after canonicalization\n")
  (display "  'optimized           show forms after optimization\n")
  (display "  'cps                 show forms after CPS-conversion\n")
  (display "  'strict              enable strict mode\n")
  (display "  'optimize            enable optimizations\n")
  (display "  'block               enable block-compilation\n")
  (display "  'library-path [DIR]  add DIR to library path or return library path\n")
  (display "  'namespace VAR       put globals into module\n")
  (display "  'xref                show cross-reference\n")
  (display "  'runtime             include runtime-system in generated code\n")
  (display "  'library             compile runtime library\n")
  (display "  'seal                wrap toplevel definitions into local scope\n")
  (display "  'debug               enable debug-mode\n")
  (display "  'usage PROC          invoke PROC on usage-errors\n")
  (display "  'fail PROC           invoke PROC on compiler-errors\n")
  (display "  'import FILENAME     expand FILENAME\n")
  (display "  'environment STORE   provide syntactic environment\n")
  (display "  'debug-syntax        show debug-output during expansion\n")
  (display "  'verbose             show diagnostic messages\n")
  (display "  'prepare             just prepare state without compiling\n")
  (display "  'code EXP            code to be compiled instead of file\n")
  (display "  'bind FILENAME       generate bindings from specifications\n")
  (display "  'output-file FILENAME   specify output-file\n"))

(define (spock . args)
  (let ((output-file #f)
	(include-runtime #f)
	(extract-library #f)
	(seal-toplevel #f)
	(files '())
	(mstore #f)
	(code #f)
	(prepare #f)
	(optimize-mode #f)
	(mstore-given #f)
	(strict-mode #f)
	(block-mode #f)
	(debug-mode #f)
	(xref-mode default-xref-mode)
	(verbose-mode #f)
	(debug-syntax #f)
	(bindings '())
	(fail error)
	(namespace #f)
	(imports '())
	(show '()))
    (define (usage opts)
      (fail "unrecgnized option or missing argument" opts))
    (define (sexpand exp dbg)
      (match-let (((exp . store) 
		   (expand-syntax exp fail mstore (and dbg debug-syntax))))
	(set! mstore store)
	exp))
    (define (compile-files state files show)
      (let ((forms
	     (or code
		 `(begin
		    ,@(map
		       read-forms
		       (note #f state files "reading source"))))))
	(if (memq 'source show)
	    (pp forms)
	    (let ((forms
		   (sexpand 
		    (note #f state forms "expanding syntax")
		    #t)))
	      (if (memq 'expand show)
		  (pp forms)
		  (let ((forms 
			 (canonicalize
			  forms
			  (note #f state state "canonicalizing"))))
		    (cond ((memq 'canonicalized show)
			   (pp forms))
			  ((and block-mode (report-undefined)))
			  ((memq 'xref show)
			   (xref #t (note #f state #t "cross-referencing")))
			  (else
			   (let ((forms (if optimize-mode
					    (optimize 
					     forms
					     (note #f state state "optimizing"))
					    forms)))
			     (if (and optimize-mode (memq 'optimized show))
				 (pp forms)
				 ;;XXX if "-runtime" + "-library":
				 ;;    xref and add compiled library.scm
				 ;;    of used definitions (sort sections topologically
				 ;;    to determine order)
				 (let ((toplambdas
					(cps
					 (note #f state forms "performing CPS conversion"))))
				   (if (memq 'cps show)
				       (for-each pp toplambdas)
				       (begin
					 (note
					  #f state
					  (generate-header state)
					  "generating code")
					 (generate-code toplambdas state)
					 (generate-trailer state)))
				   mstore)))))))))))
    (call-with-current-continuation
     (lambda (return)
       (let loop ((args args))
	 (match args
	   (() (let ((files (reverse files))
		     (state `((strict . ,strict-mode)
			      (debug . ,debug-mode)
			      (xref . ,xref-mode)
			      (seal . ,seal-toplevel)
			      (block . ,block-mode)
			      (optimize . ,optimize-mode)
			      (verbose . ,verbose-mode)
			      (fail . ,fail)
			      (runtime . ,include-runtime)
			      (library-path . ,library-path)
			      (namespace . ,namespace))))
		 (when (and (not mstore-given) extract-library)
		   (set! files 
		     (cons
		      (read-library state "library.scm" (lambda (x) x))
		      files)))
		 (when (and (not prepare) (null? files) (not code) (null? bindings))
		   (fail "nothing to compile"))
		 (when (not mstore-given)
		   (sexpand
		    (let ((m (cond (strict-mode '(default strict))
				   (debug-mode '(default debug))
				   (else '(default)))))
		      `(define-syntax define-library-section
			 (letrec-syntax 
			     ((walk
			       (syntax-rules ,m
				 ((_ ()) (%void))
				 ,@(map (lambda (m)
					  `((_ ((,m def ...) . more))
					    (begin def ...)))
					m)
				 ((_ (clause . more))
				  (walk more)))))
			   (syntax-rules ()
			     ((_ sec clause ...)
			      (begin 
				(walk (clause ...))))))))
		    #f)
		   (let ((features '(spock alexpander srfi-0 srfi-46)))
		     (when debug-mode (set! features (cons 'debug features)))
		     (when strict-mode (set! features (cons 'strict features)))
		     ;;XXX do this in a modular and extensible manner
		     (sexpand
		      `(define-syntax cond-expand
			 (syntax-rules (and or not else ,@features)
			   ((cond-expand) (syntax-error "no matching `cond-expand' clause"))
			   ,@(map (lambda (f)
				    `((cond-expand (,f body ...) . more-clauses)
				      (begin body ...)))
				  features)
			   ((cond-expand (else body ...)) (begin body ...))
			   ((cond-expand ((and) body ...) more-clauses ...) (begin body ...))
			   ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...)
			    (cond-expand
			      (req1 (cond-expand
				      ((and req2 ...) body ...)
				      more-clauses ...))
			      more-clauses ...))
			   ((cond-expand ((or) body ...) more-clauses ...) 
			    (cond-expand more-clauses ...))
			   ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...)
			    (cond-expand
			      (req1 (begin body ...))
			      (else
			       (cond-expand
				 ((or req2 ...) body ...)
				 more-clauses ...))))
			   ((cond-expand ((not req) body ...) more-clauses ...)
			    (cond-expand
			      (req (cond-expand more-clauses ...))
			      (else body ...)))
			   ((cond-expand (feature-id body ...) more-clauses ...)
			    (cond-expand more-clauses ...))))
		      #f))
		   (sexpand (read-library state "syntax.scm") #f)
		   (sexpand (read-library state "library.scm") #f))
		 (for-each
		  (lambda (bound)
		    (let ((bs (parse-bindings (read-contents bound))))
		      (if (and (null? files) (not code))
			  (pp bs)
			  (sexpand bs #t))
		      bs))
		  (reverse bindings))
		 (for-each
		  (lambda (file) (sexpand (read-forms file) #t))
		  (reverse imports))
		 (cond (prepare mstore)
		       (output-file
			(with-output-to-file output-file
			  (cut compile-files state files show)))
		       ((and (pair? bindings) (not code) (null? files)) #f)
		       (else (compile-files state files show)))))
	   (('help . _)
	    (spock-help))
	   (('output-file out . more)
	    (set! output-file out)
	    (loop more))
	   (('source . more)
	    (set! show (cons 'source show))
	    (loop more))
	   (('expand . more)
	    (set! show (cons 'expand show))
	    (loop more))
	   (('canonicalized . more)
	    (set! show (cons 'canonicalized show))
	    (loop more))
	   (('optimize . more)
	    (set! optimize-mode #t)
	    (loop more))
	   (('optimized . more)
	    (set! optimize-mode #t)
	    (set! show (cons 'optimized show))
	    (loop more))
	   (('cps . more)
	    (set! show (cons 'cps show))
	    (loop more))
	   (('strict . more)
	    (set! strict-mode #t)
	    (loop more))
	   (('block . more)
	    (set! block-mode #t)
	    (set! xref-mode #t)
	    (loop more))
	   (('import filename . more)
	    (set! imports (cons filename imports))
	    (loop more))
	   (('bind arg . more)
	    (set! bindings (cons arg bindings))
	    (loop more))
	   (('library-path)
	    (return library-path))
	   (('library-path dir . more)
	    (set! library-path (cons dir library-path))
	    (loop more))
	   (('namespace ns . more)
	    (set! namespace ns)
	    (loop more))
	   (('xref . more)
	    (set! show (cons 'xref show))
	    (set! xref-mode #t)
	    (loop more))
	   (('runtime . more)
	    (set! include-runtime #t)
	    (set! extract-library #t)
	    (loop more))
	   (('library . more)
	    (set! extract-library #t)
	    (loop more))
	   (('seal . more)
	    (set! seal-toplevel #t)
	    (loop more))
	   (('fail proc . more)
	    (set! fail proc)
	    (loop more))
	   (('usage proc . more)
	    (set! usage proc)
	    (loop more))
	   (('prepare . more)
	    (set! prepare #t)
	    (loop more))
	   (('debug . more)
	    (set! debug-mode #t)
	    (loop more))
	   (('environment store . more)
	    (set! mstore store)
	    (set! mstore-given #t)
	    (loop more))
	   (('verbose . more)
	    (set! verbose-mode #t)
	    (loop more))
	   (('debug-syntax . more)
	    (set! debug-syntax #t)
	    (loop more))
	   (('code exp . more)
	    (set! code exp)
	    (loop more))
	   (((or (? string? file) (? input-port? file)) . more)
	    (set! files (cons file files))
	    (loop more))
	   ((opts ...) (usage))))))))