;; Compiler driver routines 
;; (c) 1996-1997 Sebastian Good
;; (c) 1997-2001 PLT
;;
;; Scheme->C compilation Overview
;; ------------------------------
;;
;; Compilation is performed in a number of phases,
;;  each of which is implemented in its own unit:
;;
;;   1) Reading/parsing - Zodiac collection
;;   2) Prephase - prephase.ss
;;   3) A-normalization - anorm.ss
;;   4) Known-value analysis - known.ss
;;   5) Lexical analysis and inlining - analyze.ss
;;   6) Static procedure lifting - lift.ss
;;   7) Static procedure lifting after LWCC - lift.ss (optional)
;;   8) Closure conversion - closure.ss
;;   9) Closure vehicle assignment - vehicle.ss
;;  10) Representation choosing - rep.ss
;;  11) Scheme to virtual machine translation - vmphase.ss
;;  12) Optimizations on VM code - vmopt.ss
;;  13) VM to C translation - vm2c.ss
;;
;; For more information about a phase, see the file
;;  implementing that phase.
;;
;; All steps up to vmphase.ss work on a Scheme program, representated
;;  as a zodiac AST. The AST produced by zodiac is destructively
;;  modified by each phase (usually); mzc-specific information is
;;  stored in the AST as ``annotations''. At the implementation file
;;  for each phase, the annotations installed or changed by the phase
;;  are listed.
;;
;; All nodes in the AST must be unique, except for nodes representing
;;  constant values. Don't even reuse varref or binding nodes within
;;  an AST.
;;
;; C code is compiled and linked via procedures provided by the
;;  dynext collection.
;;
;; In this implementation, `var' is used for variable names in
;;  confusing and inconsistent ways. There are two different
;;  AST entities that could be called "var":
;;     1) binding instances of variables, e.g., the formal
;;        arguments of a lambda; these are always called
;;        `bindings' in Zodiac terminology
;;     2) bound instances of variables, e.g., a free variable 
;;        in a sub-expression; these are always called
;;        `varrefs' in Zodiac terminology.
;;  Almost all information about a variable is stored with a
;;   zodiac:binding AST node, and very little information is
;;   stored with a zodiac:varref AST node.
;;  To make matters worse, the name `binding' is overloaded.
;;    `zodiac:binding' is the name of a Zodiac structure
;;    type, and `binding' is also the name of the structure
;;    type for annotations attached to zodiac:binding objects.
;;  If you create a new lexical binding, note that the procedure
;;    zodiac:binding->lexical-varref will create varrefs to 
;;    the binding.

(module driver mzscheme
  (require mzlib/unit
	   mzlib/list
	   mzlib/file
	   mzlib/port
	   mzlib/etc
	   mzlib/pretty
	   (prefix src2src: "../src2src.ss"))
  
  (require syntax/zodiac-sig
	   syntax/toplevel
	   dynext/compile-sig
	   dynext/link-sig
	   dynext/file-sig
	   setup/dirs
           (only scheme/base 
                 define-namespace-anchor 
                 namespace-anchor->empty-namespace))

  (require "../sig.ss"
	   "sig.ss"
	   "../to-core.ss"
	   "../xform.ss")

  (provide driver@)

  (define-namespace-anchor anchor)

  (define-unit driver@
      (import (prefix compiler:option: compiler:option^)
	      compiler:library^
	      compiler:cstructs^
	      (prefix zodiac: zodiac^)
	      compiler:zlayer^
	      compiler:prephase^
	      compiler:anorm^
	      compiler:known^
	      compiler:analyze^
	      compiler:const^
	      compiler:lift^
	      compiler:closure^
	      compiler:vehicle^
	      compiler:rep^
	      compiler:vmstructs^
	      compiler:vmphase^
	      compiler:vmopt^
	      compiler:vm2c^
	      compiler:top-level^
	      dynext:compile^
	      dynext:link^
	      dynext:file^)
      (export (rename compiler:driver^
                      [compile-extension* compile-extension]))
      
      (define debug:file "dump.txt")
      (define debug:port #f)
      (define (debug:get-port) debug:port)
      (define debug
	(lambda x
	  (when (and (compiler:option:debug) debug:port)
	    (apply fprintf (cons debug:port x))
	    (flush-output debug:port))))
  
      ;;----------------------------------------------------------------------------
      ;; FILE PROCESSING FUNCTIONS
      ;;
      
      ;; takes an input-name from the compile command and returns many values:
      ;; 1) an input path
      ;; 2) a C output path
      ;; 3) a constant pool output path
      ;; 4) an obj output path
      ;; 5) a dll output path
      ;; 6) a scheme_setup suffix
      (define s:process-filenames
	(lambda (input-name dest-dir from-c? 3m? tmp-c? tmp-c3m? tmp-o?)
	  (let-values ([(basedir file dir?) (split-path input-name)])
	    (let* ([dest-dir (if (eq? dest-dir 'auto)
				 (let* ([d0 (build-path (if (eq? basedir 'relative)
							    'same
							    basedir)
							"compiled"
							"native"
							(system-library-subpath #f))]
					[d (if 3m?
					       (build-path d0 "3m")
					       d0)])
				   (unless (directory-exists? d)
				     (make-directory* d))
				   d)
				 dest-dir)]
		   [path-prefix (lambda (a b)
				  (bytes->path (bytes-append a (path->bytes b))))]
		   [path-suffix (lambda (b a)
				  (bytes->path (bytes-append (path->bytes b) a)))]
		   [sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
		   [cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
		   [base (if sbase 
                             (path-replace-suffix (path-add-suffix input-name #".x") #"")
                             cbase)]
		   [c-dir (if tmp-c?
			      (find-system-path 'temp-dir)
			      dest-dir)]
		   [c3m-dir (if tmp-c3m?
				(find-system-path 'temp-dir)
				dest-dir)]
		   [c-prefix (if tmp-c?
				 (lambda (s) (path-prefix #"mzcTMP" s))
				 values)]
		   [c3m-prefix (if tmp-c3m?
				   (lambda (s) (path-prefix #"mzcTMP" s))
				   values)]
		   [o-dir (if tmp-o?
			      (find-system-path 'temp-dir)
			      dest-dir)]
		   [o-prefix (if tmp-o?
				 (lambda (s) (path-prefix #"mzcTMP" s))
				 values)])
	      (unless base
		(error 'mzc "not a Scheme or C file: ~a" input-name))
	      (values (if sbase 
			  input-name
			  #f)
		      (if cbase 
			  input-name 
			  (build-path c-dir (c-prefix (append-c-suffix base))))
		      (and 3m?
			   (build-path c3m-dir (c3m-prefix (append-c-suffix (path-suffix base #"3m")))))
		      (build-path o-dir (o-prefix (append-constant-pool-suffix base)))
		      (build-path o-dir (o-prefix (append-object-suffix base)))
		      (build-path dest-dir (append-extension-suffix base))
		      (string-append (compiler:clean-string (compiler:option:setup-prefix)) 
				     "_" 
				     (compiler:clean-string (path->string base))))))))
      
      (define elaboration-exn-handler
	(lambda (exn)
	  (compiler:fatal-error 
	   #f
	   (format "Error during elaboration: ~a" 
		   (if (exn? exn)
		       (exn-message exn)
		       exn)))
	  (raise exn)))
      
      (define prefix-exn-handler
	(lambda (exn)
	  (compiler:fatal-error 
	   #f
	   (format "Error during prefix loading: ~a" 
		   (if (exn? exn)
		       (exn-message exn)
		       exn)))
	  (raise exn)))
      
      (define top-level-exn-handler
	(lambda (exn)
	  (set! compiler:messages (reverse compiler:messages))
	  (compiler:report-messages! #t)
	  (raise-user-error "compile failed")))
  
      (define s:expand-top-level-expressions!
	(lambda (input-directory reader verbose?)
	  (when verbose? (printf "~n Reading... ") (flush-output))
	  ;; During reads, errors are truly fatal
	  (let ([exprs (let ([failed? #f])
			 (let loop ([n 1])
			   (let ([sexp (reader)])
			     (if (eof-object? sexp)
				 null
				 (begin 
				   (when (compiler:option:debug)
				     (debug "~a[~a.~a]_"
					    n
					    (syntax-line sexp)
					    (syntax-column sexp)))
				   (cons sexp (loop (+ n 1))))))))])
	    (unless (null? compiler:messages) (when (compiler:option:verbose) (newline)))
	    (compiler:report-messages! #t)
	    (when verbose? (printf " expanding...~n"))
	    (parameterize ([current-load-relative-directory input-directory])
	      (map (lambda (expr)
		     (let ([expanded ((if has-prefix?
					  expand-top-level-with-compile-time-evals
					  expand) 
				      expr)])
		       (values ; use to be zodiac:syntax->zodiac here
			(let ([p (src2src:optimize expanded #t)])
			  '(with-output-to-file "/tmp/l.ss"
			     (lambda () (pretty-print (syntax-object->datum p)))
			     'replace)
			  (let ([opt-expanded (expand p)])
			    ;; (pretty-print (syntax-object->datum opt-expanded))
			    opt-expanded)))))
		   exprs)))))

      (define elaborate-namespace 
        (let ([ns (make-namespace)])
          (namespace-attach-module (namespace-anchor->empty-namespace anchor)
                                   'scheme/base
                                   ns)
          ns))

      (define has-prefix? #f)

      (define (eval-compile-prefix prefix)
	(set! has-prefix? (and prefix #t))
	(with-handlers ([void top-level-exn-handler])
	  (with-handlers ([void prefix-exn-handler])
	    (parameterize ([current-namespace elaborate-namespace])
	      (eval (or prefix
			;; Need MzScheme and cffi:
			'(begin
			   (require compiler/cffi)
			   (require-for-syntax mzscheme))))))))

      ;;----------------------------------------------------------------------
      ;; Misc utils      

      (define (simple-constant? s)
	(or (identifier? s)
	    (number? (syntax-e s))
	    (empty? (syntax-e s))
	    (memq (syntax-e s) '(#t #f))))

      ;; takes a list of a-normalized expressions and analyzes them
      ;; returns the analyzed code, a list of local variable lists, 
      ;; used variable lists, and captured variable lists
      (define s:analyze-source-list
	(lambda (source)
	  (let loop ([sexps source] [source-acc null] 
				    [locals-acc null] [globals-acc null] [used-acc null] [captured-acc null]
				    [children-acc null]
				    [max-arity 0])
	    (if (null? sexps)
		(values (reverse source-acc)
			(map (lambda (loc glob used cap children)
			       (let ([c (make-code empty-set
						   loc
						   glob
						   used
						   cap
						   #f
						   #f
						   children)])
				 (for-each (lambda (child) (set-code-parent! child c)) children)
				 c))
			     (reverse locals-acc)
			     (reverse globals-acc)
			     (reverse used-acc)
			     (reverse captured-acc)
			     (reverse children-acc))
			max-arity)
		(begin

		  ;; (printf "~a~n" (syntax-line (zodiac:zodiac-stx (car sexps))))

		  (let-values ([(exp free-vars local-vars global-vars used-vars captured-vars
				     children new-max-arity multi)
				(analyze-expression! (car sexps) empty-set null (null? (cdr sexps)))])

		    
		    (let ([sc-max-arity 0])

		      (loop (cdr sexps) 
			    (cons exp source-acc) 
			    (cons local-vars locals-acc)
			    (cons global-vars globals-acc)
			    (cons used-vars used-acc)
			    (cons captured-vars captured-acc)
			    (cons children children-acc)
			    (max max-arity new-max-arity sc-max-arity)))))))))

      ;; Lift static procedures
      (define s:lift
	(lambda ()
	  (compiler:init-lifted-lambda-list!)
	  (compiler:init-once-closure-lists!)

	  (let ([l (map lift-lambdas! (block-source s:file-block) (block-codes s:file-block))]
		[reset-globals (lambda (code globals)
				 (set-code-global-vars! code globals)
				 code)])
	    
	    ;; Splice lifted lambda definitions into the program in the right
	    ;; place: statics after true constants, and per-load statics after
	    ;; per-load constants.
	    (let loop ([n number-of-true-constants]
		       [l l][c (block-codes s:file-block)]
		       [l-acc null][c-acc null])
	      (if (zero? n)
		  (let loop ([n number-of-per-load-constants]
			     [l l][c c]
			     [pll-acc null][plc-acc null])
		    (if (zero? n)
			(let ([lifted-lambdas (compiler:get-lifted-lambdas)]
			      [once-closures (compiler:get-once-closures-list)])

			  (let ([naya (append lifted-lambdas once-closures)])
			    (set-block-magics! s:file-block (append (map (lambda (x) #f) naya)
								    (block-magics s:file-block)))
			    (set-block-bytecodes! s:file-block (append (map (lambda (x) #f) naya)
								       (block-bytecodes s:file-block))))
	    
			  (set-block-source! 
			   s:file-block
			   (append (reverse l-acc)
				   lifted-lambdas
				   (reverse pll-acc)
				   once-closures
				   (map car l)))
			  (set-block-codes!
			   s:file-block 
			   (append (reverse c-acc) 
				   (map
				    (lambda (ll)
				      (make-code empty-set
						 empty-set
						 empty-set ; no globals
						 empty-set
						 empty-set
						 #f #f
						 (list 
						  (get-annotation 
						   (zodiac:define-values-form-val ll)))))
				    (compiler:get-lifted-lambdas))
				   (reverse plc-acc)
				   (map (lambda (ll globs) 
					  (make-code empty-set
						     empty-set
						     globs
						     empty-set
						     empty-set
						     #f #f
						     (list
						      (get-annotation 
						       (zodiac:define-values-form-val 
							ll)))))
					(compiler:get-once-closures-list)
					(compiler:get-once-closures-globals-list))
				   (map reset-globals c (map cdr l)))))
			(loop (sub1 n) (cdr l) (cdr c) 
			      (cons (caar l) pll-acc) (cons (reset-globals (car c) (cdar l)) plc-acc))))
		  (loop (sub1 n) (cdr l) (cdr c) 
			(cons (caar l) l-acc) (cons (reset-globals (car c) (cdar l)) c-acc)))))
	  
	  ;; Lifted lambdas are true constants:
	  (set! number-of-true-constants (+ number-of-true-constants
					    (length (compiler:get-lifted-lambdas))))))

      (define s:append-block-sources!
	(lambda (file-block l)
	  (set-block-codes!
	   file-block
	   (append
	    (map
	     (lambda (glob)
	       (make-code empty-set
			  empty-set
			  empty-set
			  empty-set
			  empty-set
			  #f #f null))
	     l)
	    (block-codes file-block)))
	  (set-block-source! 
	   file-block
	   (append l (block-source file-block)))
	  (set-block-bytecodes! 
	   file-block
	   (append (map (lambda (x) #f) l)
		   (block-bytecodes file-block)))
	  (set-block-magics! 
	   file-block
	   (append (map (lambda (x) #f) l)
		   (block-magics file-block)))))

      (define (open-input-scheme-file path)
	(let ([p (let ([open (with-handlers ([exn:fail? (lambda (x) #f)])
			       (dynamic-require 'mred 'open-input-graphical-file))])
		   (if open
		       ;; Handles WXME files:
		       (open path)
		       ;; Check for WXME and give a nice error message:
		       (let ([p (open-input-file path)])
			 (when (regexp-match-peek "^WXME01[0-9][0-9] ## " p)
			   (close-input-port p)
			   (error 'compile-file
				  "file appears to have graphical syntax (try gmzc): ~a"
				  path))
			 p)))])
	  p))

      ;;-------------------------------------------------------------------------------
      ;; ERROR/WARNING REPORTING/HANDLING ROUTINES
      ;;
      (define compiler:messages null)
      (define compiler:make-message
	(lambda (constructor)
	  (lambda (ast message)
	    (set! compiler:messages (cons (constructor ast message)
					  compiler:messages)))))
      (define compiler:error (compiler:make-message make-compiler:fatal-error-msg))
      (define compiler:fatal-error compiler:error)
      (define compiler:internal-error
	(case-lambda
	 [(ast message)
	  (set! compiler:messages 
		(reverse (cons (make-compiler:internal-error-msg ast message)
				compiler:messages)))
	  (compiler:report-messages! #t)]
	 [(ast fmt . args)
	  (compiler:internal-error ast (apply format fmt args))]))
      
      (define compiler:warning (compiler:make-message make-compiler:warning-msg))

      (define compiler:report-messages!
	(lambda (stop-on-errors?)
	  (let ([error-count 0]
		[fatal-error-count 0]
		[msgs (reverse compiler:messages)])
	    (set! compiler:messages null)
	    (for-each (lambda (message)
			(when (compiler:error-msg? message) 
			  (set! error-count (add1 error-count)))
			(when (or (compiler:fatal-error-msg? message) 
				  (compiler:internal-error-msg? message))
			  (set! fatal-error-count (add1 fatal-error-count)))

			(let* ([ast (compiler:message-ast message)]
			       [string (compiler:message-message message)])
			  (zodiac:print-start! (current-output-port) ast)
			  (printf 
			   "~a: ~a~n"
			   (cond
			    [(compiler:error-msg? message) "Error"]
			    [(compiler:warning-msg? message) "Warning"]
			    [(compiler:fatal-error-msg? message) "Error"]
			    [(compiler:internal-error-msg? message) "INTERNAL ERROR"]
			    [else (error 'report-messages "internal error")])
			   string)
			  (when (compiler:internal-error-msg? message)
			    (printf 
			     (string-append
			      " please report the bug using Help Desk~n"
			      "  or http://bugs.racket-lang.org/~n"
			      "  and include a transcript in verbose mode~n")))))
		      
		      msgs)
	    (when (and stop-on-errors?
		       (or (positive? error-count)
			   (positive? fatal-error-count)))
	      (raise-user-error "Errors encountered.  Compilation aborted.")))))

      (define total-cpu-time 0)
      (define total-real-time 0)
      (define verbose-time
	(lambda (thunk)
	  (let-values ([(vals cpu real gc) (time-apply thunk null)])
	    (set! total-cpu-time (+ total-cpu-time cpu))
	    (set! total-real-time (+ total-real-time real))
	    (when (compiler:option:verbose)
	      (printf "      [cpu: ~ams, real: ~ams, gc: ~ams]~n" cpu real gc))
	    (apply values vals))))

      ;;-----------------------------------------------------------------------------
      ;; File-level Block information
      
      (define s:file-block (make-empty-block))
      (define s:max-arity 0) ; compilation-wide max
      (define s:register-max-arity!
	(lambda (n) (set! s:max-arity (max s:max-arity n))))

      (define number-of-true-constants 0)
      (define number-of-per-load-constants 0)
      
      (define s:unit-list null) ; list of units in the code
      
      (define compiler:setup-suffix "")

      (define (get-s:file-block) s:file-block)
      (define (compiler:get-setup-suffix) compiler:setup-suffix)

      (define c-declares null)
      (define (register-c-declaration str)
	(set! c-declares (cons str c-declares)))

      (define c-lambdas null)
      (define (register-c-lambda-function name body)
	(set! c-lambdas (cons (cons name body) c-lambdas)))

      ;;-----------------------------------------------------------------------------
      ;; THE MAIN DRIVING ROUTINE

      (define (compile-extension* input-name dest-directory)
	(s:compile #f #f #f input-name dest-directory))
      (define (compile-extension-to-c input-name dest-directory)
	(s:compile #t #f #f input-name dest-directory))
      (define (compile-c-extension input-name dest-directory)
	(s:compile #f #f #t input-name dest-directory))

      (define (compile-extension-part input-name dest-directory)
	(s:compile #f #t #f input-name dest-directory))
      (define (compile-extension-part-to-c input-name dest-directory)
	(s:compile #t #t #f input-name dest-directory))
      (define (compile-c-extension-part input-name dest-directory)
	(s:compile #f #t #t input-name dest-directory))

      (define compiler:multi-o-constant-pool (make-parameter #f))

      (define compiler:module-decl-name #f)

      (define s:compile
	(lambda (c-only? multi-o? from-c? input-name dest-directory)
	  (define input-directory 
	    (let-values ([(base file dir?)
			  (split-path (path->complete-path input-name))])
	      base))
	  (compiler:multi-o-constant-pool multi-o?)
	  (set! s:file-block (make-empty-block))
	  (set! s:max-arity 0)
	  (set! total-cpu-time 0)
	  (set! total-real-time 0)
	  (random-seed (compiler:option:seed))
	  (set! compiler:messages null)
	  (set! c-declares null)
	  (set! c-lambdas null)
	  (const:init-tables!)
	  (compiler:init-closure-lists!)
	  ; process the input string - try to open the input file
	  (let-values ([(input-path c-output-path c3m-output-path
				    constant-pool-output-path obj-output-path dll-output-path 
				    setup-suffix)
			(s:process-filenames input-name dest-directory from-c?
					     (compiler:option:3m)
					     (and (compiler:option:clean-intermediate-files)
						  (or (not c-only?)
						      (compiler:option:3m)))
					     (and (compiler:option:clean-intermediate-files)
						  (not c-only?))
					     (and (compiler:option:clean-intermediate-files)
						  (not multi-o?)))])
	    (unless (or (not input-path) (file-exists? input-path))
	      (error 's:compile "could not open ~a for input" input-path))
	    (set! compiler:setup-suffix
		  (if multi-o?
		      setup-suffix
		      ""))
	    
	    (for-each (lambda (path)
			(when (file-exists? path) (delete-file path)))
		      (list (if input-path c-output-path obj-output-path) 
			    (if input-path constant-pool-output-path obj-output-path) 
			    (or c3m-output-path obj-output-path)
			    obj-output-path dll-output-path))
	
	    (when (compiler:option:debug)
	      (when (file-exists? debug:file) (delete-file debug:file))
	      (set! debug:port (open-output-file debug:file 'text)))
	
	    (when input-path 
	      (parameterize ([main-source-file input-path])
		(let ([input-port (open-input-scheme-file input-path)])
		  (port-count-lines! input-port)

		  ;;-----------------------------------------------------------------------
		  ;; read all top-level s-expressions
		  ;;
	      
                  (when (compiler:option:somewhat-verbose)
                    (printf "\"~a\": " input-path)
                    (unless (compiler:option:verbose) (newline)))
		  (let ([read-thunk
			 (lambda ()
			   (with-handlers ([void top-level-exn-handler])
			     (with-handlers ([void elaboration-exn-handler])
			       (parameterize ([current-namespace elaborate-namespace]
					      [compiler:escape-on-error #t])
				 (set-block-source! 
				  s:file-block
				  (s:expand-top-level-expressions! 
				   input-directory
				   (lambda ()
                                     (parameterize ([read-accept-reader #t])
                                       (read-syntax (path->complete-path input-path) input-port)))
				   (compiler:option:verbose)))))))])
		    (verbose-time read-thunk)
		    (close-input-port input-port)
		    (set! input-port #f)
		
		    (compiler:report-messages! #t))
	
		  ;; (print-struct #t) (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))
		  
		  ;; (map (lambda(ast)(pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
		  
		  ;; (print-graph #t) (display (car (block-source s:file-block))) (newline)

		  ;;-----------------------------------------------------------------------
		  ;; record module name, if a single declaration
		  ;;

		  (set-single-module-mode! #f)
		  (when (= 1 (length (block-source s:file-block)))
		    (syntax-case (car (block-source s:file-block)) (module)
		      [(module name . _)
		       (begin
			 (set-single-module-mode! #t)
			 (set! compiler:module-decl-name (syntax-e #'name)))]
		      [_else (void)]))
		  
		  ;;-----------------------------------------------------------------------
		  ;; ensure that no `module', `require', or `require-for-syntax'
		  ;; expression is inside a `begin'

		  (letrec ([needs-split?
			    (lambda (stx saw-begin?)
			      (syntax-case stx (begin module require require-for-syntax)
				[(module . _) saw-begin?]
				[(require . _) saw-begin?]
				[(require-for-syntax . _) saw-begin?]
				[(begin . e)
				 (ormap (lambda (x) (needs-split? x #t))
					(syntax->list #'e))]
				[_else #f]))]
			   [split
			    (lambda (stx)
			      (syntax-case stx (begin)
				[(begin . e)
				 (apply append (map split (syntax->list #'e)))]
				[_else (list stx)]))])
		    (set-block-source! 
		     s:file-block
		     (apply
		      append
		      (map (lambda (e)
			     (if (needs-split? e #f)
				 (split e)
				 (list e)))
			   (block-source s:file-block)))))
		  
		  ;;-----------------------------------------------------------------------
		  ;; Extract stateless, phaseless core, leaving the rest of bytecode
		  ;;
		  
		  (when (compiler:option:verbose) (printf " extracting core expressions~n"))
		  (when (compiler:option:debug) (debug " = CORE =~n"))

		  (let ([core-thunk
			 (lambda ()
			   (parameterize ([current-namespace elaborate-namespace]
					  [current-load-relative-directory input-directory]
					  [compile-enforce-module-constants #f])
                             (let ([sources+bytecodes+magics
				    (map (lambda (src)
					   (let-values ([(src bytecode magic-sym)
							 (top-level-to-core src 
									    #`'#,zodiac:global-lookup-id
									    #`'#,zodiac:global-assign-id
									    #`'#,zodiac:safe-vector-ref-id
									    #`'#,zodiac:global-prepare-id
									    simple-constant?
									    '(mzc-cffi))])
					     (list (zodiac:syntax->zodiac src) 
						   bytecode magic-sym)))
					 (block-source s:file-block))])
			       (set-block-source! s:file-block (map car sources+bytecodes+magics))
                               (set-block-bytecodes! s:file-block 
						     (map compile
							  (map cadr sources+bytecodes+magics)))
			       (set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))])
		    (verbose-time core-thunk))

		  ;;-----------------------------------------------------------------------
		  ;; Run a preprocessing phase on the input
		  ;;
	      
		  (when (compiler:option:verbose) (printf " pre-processing and scanning for errors~n"))
		  (when (compiler:option:debug) (debug " = PREPHASE =~n"))
	      
		  (let ([prephase-thunk 
			 (lambda () 
			   (set-block-source! 
			    s:file-block
			    (let loop ([source (block-source s:file-block)]
				       [errors compiler:messages])
			      (if (null? source)
				  source
				  (let ([ast (prephase! (car source) #f (null? (cdr source)) #f)])
				    (if (eq? errors compiler:messages)
					
					;; no errors here
					(cons ast (loop (cdr source) errors))
					
					;; error, drop this one
					(loop (cdr source) compiler:messages)))))))])
		    (verbose-time prephase-thunk))
		  (compiler:report-messages! (not (compiler:option:test)))
		  (when (compiler:option:test)
		    (printf "skipping over top-level expressions with errors...~n"))
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; A-normalize input
	      ;;
	      
	      (when (compiler:option:verbose) (printf " transforming to a-normal form~n"))
	      (when (compiler:option:debug) (debug " = ANORM =~n"))
	      
	      (let ([anorm-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block 
			(map (lambda (s) (a-normalize s identity)) 
			     (block-source s:file-block))))])
		(verbose-time anorm-thunk))
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; known-value analysis
	      ;;

	      (when (compiler:option:verbose) 
		(printf " determining known bindings~n"))
	      (when (compiler:option:debug)
		(debug " = KNOWN =~n"))

	      ; analyze top level expressions
	      (let ([known-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block 
			(map (lambda (s) (analyze-knowns! s)) 
			     (block-source s:file-block))))])
		(verbose-time known-thunk))

	      (compiler:report-messages! #t)
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; B-form transformation and analysis
	      ;;

	      (when (compiler:option:verbose) 
		(printf " transforming to b-normal form, analyzing, and inlining~n"))
	      (when (compiler:option:debug)
		(debug " = ANALYZE =~n"))

	      ; analyze top level expressions, cataloguing local variables
	      (compiler:init-define-lists!)
	      (let ([bnorm-thunk
		     (lambda ()
		       (let-values ([(new-source new-codes max-arity)
				     (s:analyze-source-list 
				      (block-source s:file-block))])
			 (set-block-source! s:file-block new-source)
			 (set-block-codes! s:file-block new-codes)
			 (block:register-max-arity! s:file-block max-arity)
			 (s:register-max-arity! max-arity))

		       ;; take constant construction code and place it in front of the 
		       ;; previously generated code. True constants first.
		       (set! number-of-true-constants (length (compiler:get-define-list)))
		       (set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list))))
		       (s:append-block-sources! s:file-block 
						(append
						 (compiler:get-define-list)
						 (compiler:get-per-load-define-list))))])
		(verbose-time bnorm-thunk))
	      (compiler:report-messages! #t)

	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; Lift static procedures
	      ;;

	      (when (compiler:option:verbose) 
		(printf " finding static procedures~n"))
	      (when (compiler:option:debug)
		(debug " = LIFT =~n"))

	      (let ([lift-thunk s:lift])
		(verbose-time lift-thunk))
	      (compiler:report-messages! #t)
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; Closure conversion and explicit control transformation
	      ;;
	      
	      (when (compiler:option:verbose) 
		(printf " closure conversion and explicit control transformation~n"))
	      
	      (let ([closure-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block
			(map closure-expression! (block-source s:file-block))))])
		(verbose-time closure-thunk))
	      
	      ;;-----------------------------------------------------------------------
	      ;; Vehicle assignment
	      ;;
	      ;; Set export list offset for units at the same time
	      ;;
	      
	      (when (compiler:option:verbose)
		(printf " closure->vehicle mapping~n"))
	      
	      (when (eq? (compiler:option:vehicles) 'vehicles:automatic)
		(for-each 
		 (lambda (L)
		   (when (zodiac:case-lambda-form? L)
		     (map (lambda (body)
			    (relate-lambdas! L body))
			  (zodiac:case-lambda-form-bodies L))))
		 (compiler:get-closure-list)))
	      
	      (when (eq? (compiler:option:vehicles) 'vehicles:units)
		(compiler:fatal-error 
		 #f 
		 "unit-wise vehicle mapping not currently supported~n"))
	      (let ([vehicle-thunk
		     (lambda ()
		       (compiler:init-vehicles!)
		       (compiler:reset-label-number!)
		       (choose-vehicles!))])
		(verbose-time vehicle-thunk))

	      ;;-----------------------------------------------------------------------
	      ;; Representation Choosing 
	      ;;    From this stage, we have to work with separate code bodies, as well
	      ;;    as the list of top-level expressions.
	      
	      (when (compiler:option:verbose) 
		(printf 
		 " choosing data representations~n"))
	      
	      (let ([rep-thunk
		     (lambda ()
		       (compiler:init-structs!)
		       ; top-level
		       (map
			(lambda (c)
			  (choose-binding-representations! 
			   (code-local-vars c)
			   (code-global-vars c)
			   (code-used-vars c)
			   (code-captured-vars c)))
			(block-codes s:file-block))
		       ; code-bodies
		       (for-each (lambda (L)
				   (let* ([code (get-annotation L)]
					  [locals (code-local-vars code)]
					  [globals (code-global-vars code)]
					  [used (code-used-vars code)]
					  [captured (code-captured-vars code)])
				     (choose-binding-representations! locals globals used captured)
				     (choose-closure-representation! code)))
				 (compiler:get-closure-list)))])
		(verbose-time rep-thunk))

	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine Scheme translation
	      ;;   Here we turn our code into VM Scheme as we enter the arena of
	      ;;    low level transformations and optimizations.
	      ;;   This transformation may create new local variables, so
	      ;;    we have to update the local variable set for each top-level
	      ;;    expression or code body.
	      
	      (when (compiler:option:verbose) (printf " transforming to Virtual Machine form~n"))
	      (when (compiler:option:debug) (debug " = VMPHASE =~n"))
	      
	      (let ([vmphase-thunk
		     (lambda ()
		       ; top-level.  The last expression will be in tail position and should
		       ; return its value
                       (set-block-source!
                        s:file-block
                        (let loop ([s (block-source s:file-block)]
                                   [l (block-codes s:file-block)]
                                   [m (block-magics s:file-block)])
                          (if (null? s)
                              null
                              (let-values ([(vm new-locals)
                                            (vm-phase (car s) 
                                                      #t
                                                      #f
                                                      (if (null? (cdr s))
                                                          (lambda (ast)
                                                            (make-vm:return 
                                                             (zodiac:zodiac-stx ast)
                                                             ast
                                                             (and (car m) #t)))
                                                          (lambda (ast)
                                                            (make-vm:void
                                                             (zodiac:zodiac-stx ast)
                                                             ast
                                                             (and (car m) #t))))
                                                      (null? (cdr s))
                                                      (and (car m) #t))])
                                (add-code-local+used-vars! (car l) new-locals)
                                (cons vm
                                      (loop (cdr s) (cdr l) (cdr m)))))))
		       ; code-bodies
		       (for-each 
			(lambda (L)
			  (let* ([code (get-annotation L)]
				 [tail-pos (lambda (ast)
					     (make-vm:return 
					      (zodiac:zodiac-stx ast)
					      ast
					      #f))]
				 [new-locals
				  (cond
				   [(zodiac:case-lambda-form? L)
				    (let-values ([(vms new-locals)
						  (let loop ([l (zodiac:case-lambda-form-bodies L)]
							     [case-codes (procedure-code-case-codes 
									  (get-annotation L))]
							     [vms null])
						    (if (null? l)
							(values (reverse vms) 
								; empty: already added via case
								empty-set) 
							(let-values ([(vm new-locals)
								      (vm-phase (car l) #t #f tail-pos #t #f)])
							  (add-code-local+used-vars! 
							   (car case-codes)
							   new-locals )
							  (loop (cdr l)
								(cdr case-codes)
								(cons vm vms)))))])
				      (zodiac:set-case-lambda-form-bodies! L vms)
				      new-locals)]
				   [else (compiler:internal-error
					  L
					  "vmphase: unknown closure type")])])
			    (add-code-local+used-vars! code new-locals)))
			(compiler:get-closure-list)))])
		(verbose-time vmphase-thunk))

	      (compiler:report-messages! #t)

	      ; (print-struct #t)
	      ; (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine Optimization Pass
	      ;;
	      ;;  As in the previous phase, new local variables may be created.
	      
	      (when (compiler:option:verbose) (printf " optimizing Virtual Machine code~n"))
	      
	      (let ([vmopt-thunk
		     (lambda ()
		       ; top-level
                       (set-block-source!
                        s:file-block
                        (let loop ([bl (block-source s:file-block)]
                                   [cl (block-codes s:file-block)])
                          (if (null? bl)
                              null
                              (let-values ([(b new-locs) ((vm-optimize! #f #f) (car bl))])
                                (add-code-local+used-vars! (car cl) new-locs)
                                (cons b (loop (cdr bl) (cdr cl)))))))
		       
		       ; code-bodies
		       (for-each (lambda (L)
				   (let ([code (get-annotation L)])
				     (cond
				      [(zodiac:case-lambda-form? L)
                                       (zodiac:set-case-lambda-form-bodies!
                                        L
                                        (let loop ([bodies (zodiac:case-lambda-form-bodies L)]
                                                   [case-codes (procedure-code-case-codes code)]
                                                   [i 0])
                                          (if (null? bodies)
                                              null
                                              (let-values ([(new-body new-locs) ((vm-optimize! L i) (car bodies))])
                                                (add-code-local+used-vars! (car case-codes)
                                                                           new-locs)
                                                (cons new-body
                                                      (loop (cdr bodies)
                                                            (cdr case-codes)
                                                            (add1 i)))))))]
				      [else (compiler:internal-error
					     L
					     "vmopt: unknown closure type")])))
				 (compiler:get-closure-list)))])
		(verbose-time vmopt-thunk))
		 
	      (compiler:report-messages! #t)
			  
	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine -> ANSI C translation
	      ;;
	      (when (compiler:option:verbose)
		(printf " [emitting ~a C to \"~a\"]~n" 
			"ANSI"
			c-output-path))
	
	      (let ([vm2c-thunk
		     (lambda ()
		       (parameterize ([read-case-sensitive #t]) ;; so symbols containing uppercase print like we want
			 (let ([c-port #f])
			   (dynamic-wind 
			       ;;pre
			       (lambda () (set! c-port (open-output-file c-output-path)))
			       
			       ;;value
			       (lambda ()
				 (fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name)
				 (when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n"))
				 (when (compiler:option:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1~n"))
				 (when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1~n"))
				 
				 (fprintf c-port "~n#include \"~ascheme.h\"~n"
					  (if (compiler:option:compile-for-embedded)
					      ""
					      "e"))
				 
				 (unless (null? c-declares)
				   (fprintf c-port "~n/* c-declare literals */~n~n")
				   (for-each
				    (lambda (c-declare)
				      (fprintf c-port "~a~n" c-declare))
				    (reverse c-declares))
				   (fprintf c-port "~n/* done with c-declare literals */~n~n"))

				 (unless (null? c-lambdas)
				   (fprintf c-port "~n/* c-lambda implementations */~n~n")
				   (for-each
				    (lambda (c-lambda)
				      (let ([name (car c-lambda)]
					    [body (cdr c-lambda)])
					(fprintf c-port "Scheme_Object *~a(int argc, Scheme_Object **argv) {\n"
						 name)
					(fprintf c-port "~a~n" body)
					(fprintf c-port "}~n")))
				    (reverse c-lambdas))
				   (fprintf c-port "~n/* done with c-lambda implementations */~n~n"))

				 (fprintf c-port "#include \"mzc.h\"~n~n")
				 (vm->c:emit-struct-definitions! (compiler:get-structs) c-port)
				 (vm->c:emit-symbol-declarations! c-port)
				 (vm->c:emit-inexact-declarations! c-port)
				 (vm->c:emit-string-declarations! c-port)
				 (vm->c:emit-prim-ref-declarations! c-port)
				 (vm->c:emit-static-declarations! c-port)

				 (let loop ([c 0][l (block-bytecodes s:file-block)][m (block-magics s:file-block)])
				   (cond
				    [(null? l) (void)]
				    [(not (car l)) (loop c (cdr l) (cdr m))]
				    [else
				     (vm->c:emit-bytecode-string-definition! 
				      (format "top_level_bytecode_~a" c)
				      (car l)
				      c-port)
				     (fprintf c-port "#define top_level_magic_sym_~a ~s\n\n"
					      c
					      (symbol->string (car m)))
				     (loop (add1 c) (cdr l) (cdr m))]))
				 
				 (let loop ([n 0])
				   (unless (= n (compiler:get-total-vehicles))
				     (vm->c:emit-vehicle-declaration c-port n)
				     (loop (+ n 1))))
				 (newline c-port)
				 
				 (unless (compiler:multi-o-constant-pool)
				   (fprintf c-port "~nstatic void make_symbols()~n{~n")
				   (vm->c:emit-symbol-definitions! c-port)
				   (fprintf c-port "}~n"))

				 (unless (zero? (const:get-inexact-counter))
				   (fprintf c-port "~nstatic void make_inexacts()~n{~n")
				   (vm->c:emit-inexact-definitions! c-port)
				   (fprintf c-port "}~n"))

				 (fprintf c-port "~nstatic void gc_registration()~n{~n")
				 (vm->c:emit-registration! c-port)
				 (fprintf c-port "}~n")

				 (fprintf c-port "~nstatic void init_prims(Scheme_Env * env)~n{~n")
				 (vm->c:emit-prim-ref-definitions! c-port)
				 (fprintf c-port "}~n")
				 
				 (unless (null? (compiler:get-case-lambdas))
				   (fprintf c-port "~nstatic void init_cases_arities()~n{~n")
				   (vm->c:emit-case-arities-definitions! c-port)
				   (fprintf c-port "}~n"))
				 (newline c-port)

				 (let* ([codes (block-codes s:file-block)]
					[locals (map code-local-vars codes)]
					[globals (map code-global-vars codes)]
					[init-constants-count
					 (if (zero? number-of-true-constants)
					     -1
					     (vm->c:emit-top-levels! "init_constants" #f #f #t number-of-true-constants
								     (block-source s:file-block)
								     locals globals
								     (block-max-arity s:file-block)
								     #f #f ; no module entries
								     c-port))]
					[top-level-count
					 (vm->c:emit-top-levels! "top_level" #t #t #f -1
								 (list-tail (block-source s:file-block) number-of-true-constants)
								 (list-tail locals number-of-true-constants)
								 (list-tail globals number-of-true-constants)
								 (block-max-arity s:file-block)
								 #f #f ; no module entries
								 c-port)])
				   (fprintf c-port
					    "static Scheme_Object * do_scheme_reload(Scheme_Env * env)~n{~n")
				   (fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n"
					    vm->c:indent-spaces)
				   (fprintf c-port 
					    "~aPLS = (Scheme_Per_Load_Statics *)scheme_malloc(sizeof(Scheme_Per_Load_Statics));~n"
					    vm->c:indent-spaces)
				   (let loop ([c 0])
				     (fprintf c-port "~a~atop_level_~a(env, PLS);~n" 
					      vm->c:indent-spaces 
					      (if (= c top-level-count) "return " "")
					      c)
				     (unless (= c top-level-count)
				       (loop (add1 c))))
				   (fprintf c-port 
					    "}~n~n")


				   (fprintf c-port
					    "Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n"
					    compiler:setup-suffix)
				   (fprintf c-port"~areturn do_scheme_reload(env);~n"
					    vm->c:indent-spaces)
				   (fprintf c-port 
					    "}~n~n")

				   (fprintf c-port
					    "~nstatic void do_scheme_setup(Scheme_Env * env)~n{~n")
				   (fprintf c-port
					    "~ascheme_set_tail_buffer_size(~a);~n"
					    vm->c:indent-spaces
					    s:max-arity)
				   (fprintf c-port "~agc_registration();~n"
					    vm->c:indent-spaces)
				   (unless (compiler:multi-o-constant-pool)
				     (fprintf c-port "~amake_symbols();~n"
					      vm->c:indent-spaces))
				   (unless (zero? (const:get-inexact-counter))
				     (fprintf c-port "~amake_inexacts();~n"
					      vm->c:indent-spaces))
				   (fprintf c-port "~ainit_prims(env);~n"
					    vm->c:indent-spaces)
				   (unless (null? (compiler:get-case-lambdas))
				     (fprintf c-port "~ainit_cases_arities();~n"
					      vm->c:indent-spaces))		       

				   (let loop ([c 0])
				     (unless (> c init-constants-count)
				       (fprintf c-port "~ainit_constants_~a(env);~n" 
						vm->c:indent-spaces
						c)
				       (loop (add1 c))))

				   (fprintf c-port 
					    "}~n~n")

                                   (fprintf c-port
					    "~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
					    compiler:setup-suffix)
				   (fprintf c-port
					    "~ado_scheme_setup(env);~n"
					    vm->c:indent-spaces)
				   (fprintf c-port 
					    "}~n~n")
				   
				   (when (string=? "" compiler:setup-suffix)
				     (fprintf c-port
					      "~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n")
				     (fprintf c-port "~ado_scheme_setup~a(env);~n"
					      vm->c:indent-spaces
					      compiler:setup-suffix)
				     (fprintf c-port "~areturn do_scheme_reload~a(env);~n"
					      vm->c:indent-spaces
					      compiler:setup-suffix)
				     (fprintf c-port 
					      "}~n~n"))

				   (fprintf c-port
					    "~nScheme_Object * ~ascheme_module_name()~n{~n~areturn "
					    compiler:setup-suffix
					    vm->c:indent-spaces)
				   (if compiler:module-decl-name
				       (let ([s (symbol->string compiler:module-decl-name)])
					 (fprintf c-port "scheme_intern_exact_symbol(~s, ~a)" s (string-length s)))
				       (fprintf c-port "scheme_false"))
				   (fprintf c-port ";~n}~n"))

				 (let emit-vehicles ([vehicle-number 0])
				   (unless (= vehicle-number (compiler:get-total-vehicles))
				     (let* ([vehicle (get-vehicle vehicle-number)]
					    [lambda-list (vehicle-lambdas vehicle)])
				       
				       (vm->c:emit-vehicle-header c-port vehicle-number)
				       (vm->c:emit-vehicle-prologue c-port vehicle)
				       
				       ;; get the lambdas that appear in this vehicle
				       
				       ;; sort the functions by index to get an optimal case statement
				       ;; even for stupid compilers
				       (set! lambda-list
					     (sort lambda-list
                                                   (lambda (l1 l2)
                                                     (< (closure-code-label (get-annotation l1))
                                                        (closure-code-label (get-annotation l2))))))
				       (for-each (lambda (L)
						   (let ([code (get-annotation L)]
							 [start (zodiac:zodiac-start L)])
						     (fprintf c-port "~a/* code body ~a ~a [~a,~a] */~n"
							      vm->c:indent-spaces (closure-code-label code)
							      (let ([n (closure-code-name code)])
								(if n
								    (protect-comment 
								     (vm->c:extract-inferred-name n))
								    ""))
							      (zodiac:location-line start)
							      (zodiac:location-column start))
						     (cond
						      [(zodiac:case-lambda-form? L)
						       (let-values ([(count suffix?) 
								     (vm->c:emit-function-prologue L c-port)])
							 (let loop ([i 0])
							   (unless (= i count)
							     (let* ([indent
								     (string-append
								      vm->c:indent-spaces vm->c:indent-spaces
								      (if suffix?  vm->c:indent-spaces ""))]
								    [undefines
								     (vm->c:emit-case-prologue L i
											       (lambda ()
												 (if suffix?
												     (fprintf c-port "~a~a/* begin case ~a */~n~a~a{~n" 
													      vm->c:indent-spaces vm->c:indent-spaces i
													      vm->c:indent-spaces vm->c:indent-spaces)
												     (when (zero? i)
												       (fprintf c-port "~a{~n" vm->c:indent-spaces))))
											       (if suffix? (format "c~a" i) "")
											       indent
											       c-port)])
							       (vm->c-expression (list-ref (zodiac:case-lambda-form-bodies L) i)
										 code
										 c-port
										 (* (if suffix? 3 2) vm->c:indent-by)
										 #f
										 -1)
							       (vm->c:emit-case-epilogue L i undefines indent c-port)
							       (when suffix?
								 (fprintf c-port "~a~a} /* end case ~a */~n" 
									  vm->c:indent-spaces 
									  vm->c:indent-spaces i)))
							     
							     (loop (add1 i))))
							 (vm->c:emit-function-epilogue code 
										       (if suffix? "" "}")
										       c-port))]
						      [else
						       (compiler:internal-error
							L
							"vm2c: unknown closure type")])
						     (newline c-port)))
						 lambda-list))
				     
				     (vm->c:emit-vehicle-epilogue c-port vehicle-number)
				     (newline c-port)
				     (emit-vehicles (+ 1 vehicle-number)))))
			       
			       ;; post (dynamic wind cleanup)
			       (lambda ()  (close-output-port c-port))))))])
		(with-handlers ([void (lambda (exn)
					(delete-file c-output-path)
					(raise exn))])
		  (verbose-time vm2c-thunk)))
	      
	      (compiler:report-messages! #t)
	      
	      ;; Write out symbols for multi-o constant pool
	      (when (compiler:multi-o-constant-pool)
		(call-with-output-file constant-pool-output-path
		  (lambda (port)
		    (fprintf port "(~s~n (symbols~n" compiler:setup-suffix)
		    (vm->c:emit-symbol-list! port "" #f)
		    (fprintf port "  )~n )~n")))))))

	;;-----------------------------------------------------------------------
	;; 3m xform
	;;
	
        (when c3m-output-path
	  (when (compiler:option:verbose)
	    (printf " [xforming C to \"~a\"]~n" 
		    c3m-output-path))

	  (let ([clean-up-src-c
		 (lambda ()
		   (when (and (compiler:option:clean-intermediate-files)
			      (not from-c?)
			      (file-exists? c-output-path))
		     (delete-file c-output-path)))])
	    (with-handlers ([void
			     (lambda (exn)
			       (when (compiler:option:clean-intermediate-files)
				 (when (file-exists? c3m-output-path)
				   (delete-file c3m-output-path)))
			       (clean-up-src-c)
			       (raise exn))])
	      
	      (xform (not (compiler:option:verbose)) 
		     (path->string c-output-path)
		     c3m-output-path
		     (list (find-include-dir)
			   (collection-path "compiler")))
	      
	      (clean-up-src-c))))

	;;--------------------------------------------------------------------
	;; COMPILATION TO NATIVE CODE
	;;
	
	(if c-only?
            (when (compiler:option:somewhat-verbose)
              (printf " [output to \"~a\"]~n" (or c3m-output-path c-output-path)))
	    
	    (begin
	      (unless input-path
                (when (compiler:option:somewhat-verbose)
                  (printf "\"~a\": ~n" (or c3m-output-path c-output-path))))
	      
	      (when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n"
						      obj-output-path))
	      
              (let ([clean-up
                     (lambda ()
                       (when (and (compiler:option:clean-intermediate-files)
                                  input-path)
                         (if c3m-output-path
                             (delete-file c3m-output-path)
                             (delete-file c-output-path))))])

                ;; Compile
                (let ([compile-thunk
                       (lambda ()
                         (with-handlers
                             ([void (lambda (exn)
                                      (clean-up)
                                      (compiler:fatal-error
                                       #f
                                       (string-append
                                        " C compiler did not complete successfully"
                                        (string #\newline)
                                        (exn-message exn)))
                                      (compiler:report-messages! #t))])
                           (compile-extension (not (compiler:option:verbose)) 
                                              (or c3m-output-path c-output-path) obj-output-path
                                              (list (collection-path "compiler")))))])
                  (verbose-time compile-thunk))

                (clean-up))
	      
	      (if multi-o?
                  (when (compiler:option:somewhat-verbose)
                    (printf " [output to \"~a\"]~n" obj-output-path))
		  
		  (begin
		    ;; Link
		    (when (compiler:option:verbose) (printf " [linking to \"~a\"]~n"
							    dll-output-path))
		    (let ([link-thunk
			   (lambda ()
			     (with-handlers
				 ([void (lambda (exn)
					  (compiler:fatal-error 
					   #f 
					   (string-append 
					    " linker did not link successfully"
					    (string #\newline)
					    (exn-message exn)))
					  (compiler:report-messages! #t))])
			       (link-extension (not (compiler:option:verbose)) (list obj-output-path) dll-output-path)))])
		      (verbose-time link-thunk))
		    
		    ;; clean-up
		    (when (compiler:option:clean-intermediate-files)
		      (delete-file obj-output-path))
		    
                    (when (compiler:option:somewhat-verbose)
                      (printf " [output to \"~a\"]~n" dll-output-path))))))
	
	(when debug:port
	  (close-output-port debug:port))
	
	;; clean up for the garbage collector
	(compiler:init-define-lists!)
	(const:init-tables!)
	(compiler:init-closure-lists!)
	(compiler:init-structs!)
	(set! s:file-block #f)
	(when (compiler:option:verbose)
	  (printf " finished [cpu ~a, real ~a].~n"
		  total-cpu-time
		  total-real-time)))))))