;; Main compilation procedures
;; (c) 1997-2001 PLT

;; The various procedures provided by this library are implemented
;;  by dynamically linking to code supplied by the MzLib, dynext, and
;;  compiler collections.

;; The Scheme->C compiler is loaded as either sploadr.ss (link in
;;  real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).

(module compiler-unit mzscheme 
  (require (lib "unitsig.ss"))

  (require "sig.ss")
  (require (lib "file-sig.ss" "dynext")
	   (lib "link-sig.ss" "dynext")
	   (lib "compile-sig.ss" "dynext")
	   
	   (lib "make-sig.ss" "make")
	   (lib "collection-sig.ss" "make")

	   (lib "toplevel.ss" "syntax")
	   (lib "moddep.ss" "syntax"))

  (require (lib "list.ss")
	   (lib "file.ss")
	   (lib "compile.ss") ; gets compile-file
	   (lib "cm.ss")
	   (lib "getinfo.ss" "setup"))

  (provide compiler@)

  (define orig-namespace (current-namespace))

  ;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;;
  (define compiler@
    (unit/sig compiler^
      (import compiler:option^
	      dynext:compile^
	      dynext:link^
	      dynext:file^)

      (define compile-notify-handler
	(make-parameter void))

      (define current-compiler-dynamic-require-wrapper
	(make-parameter (lambda (thunk)
			  (parameterize ([current-namespace orig-namespace])
			    (thunk)))))

      (define (c-dynamic-require path id)
	((current-compiler-dynamic-require-wrapper)
	 (lambda ()
	   (dynamic-require path id))))
      (define (c-get-info cp)
	((current-compiler-dynamic-require-wrapper)
	 (lambda ()
	   (get-info cp))))

      (define (make-extension-compiler mode prefix)
	(let ([u (c-dynamic-require `(lib "base.ss" "compiler" "private")
				    'base@)]
	      [init (unit/sig ()
		      (import compiler:inner^)
		      (eval-compile-prefix prefix)
		      (case mode
			[(compile-extension) compile-extension]
			[(compile-extension-to-c) compile-extension-to-c]
			[(compile-c-extension) compile-c-extension]
			[(compile-extension-part) compile-extension-part]
			[(compile-extension-part-to-c) compile-extension-part-to-c]
			[(compile-c-extension-part) compile-c-extension-part]))])
	  (invoke-unit/sig
	   (compound-unit/sig
	    (import (COMPILE : dynext:compile^)
		    (LINK : dynext:link^)
		    (DFILE : dynext:file^)
		    (OPTION : compiler:option^))
	    (link [COMPILER : compiler:inner^ (u COMPILE
						 LINK
						 DFILE
						 OPTION)] 
		  [INIT : () (init COMPILER)])
	    (export))
	   dynext:compile^
	   dynext:link^
	   dynext:file^
	   compiler:option^)))

      (define (make-compiler mode) 
	(lambda (prefix)
	  (let ([c (make-extension-compiler mode prefix)])
	    (lambda (source-files destination-directory)
	      (map
	       (lambda (source-file)
		 (c source-file (or destination-directory 'same)))
	       source-files)))))

      (define (make-unprefixed-compiler mode)
	(let ([f #f])
	  (lambda (source-files destination-directory)
	    (unless f
	      (set! f ((make-compiler mode) '(void))))
	    (f source-files destination-directory))))

      (define compile-extensions
	(make-compiler 'compile-extension))
      (define compile-extensions-to-c
	(make-compiler 'compile-extension-to-c))
      (define compile-c-extensions
	(make-unprefixed-compiler 'compile-c-extension))

      (define compile-extension-parts
	(make-compiler 'compile-extension-part))
      (define compile-extension-parts-to-c
	(make-compiler 'compile-extension-part-to-c))
      (define compile-c-extension-parts
	(make-unprefixed-compiler 'compile-c-extension-part))

      (define (link/glue-extension-parts link? source-files destination-directory)
	(let ([u (c-dynamic-require '(lib "ld-unit.ss" "compiler") 'ld@)]
	      [init (unit/sig ()
		      (import compiler:linker^)
		      (if link?
			  link-extension
			  glue-extension))])
	  (let ([f (invoke-unit/sig
		    (compound-unit/sig
		     (import (COMPILE : dynext:compile^)
			     (LINK : dynext:link^)
			     (DFILE : dynext:file^)
			     (OPTION : compiler:option^))
		     (link [LINKER : compiler:linker^ (u COMPILE 
							 LINK
							 DFILE
							 OPTION)]
			   [INIT : () (init LINKER)])
		     (export))
		    dynext:compile^
		    dynext:link^
		    dynext:file^
		    compiler:option^)])
	    (f source-files destination-directory))))

      (define (link-extension-parts source-files destination-directory)
	(link/glue-extension-parts #t source-files destination-directory))

      (define (glue-extension-parts source-files destination-directory)
	(link/glue-extension-parts #f source-files destination-directory))

      (define (compile-to-zo src dest namespace eval?)
	((if eval? (lambda (t) (t)) with-module-reading-parameterization)
	 (lambda ()
	   (parameterize ([current-namespace namespace])
	     (compile-file src dest
			   (if eval?
			       (lambda (expr)
				 (expand-syntax-top-level-with-compile-time-evals expr))
			       values)))))
	(printf " [output to \"~a\"]~n" dest))

      (define (compile-zos prefix)
	(let ([n (if prefix (make-namespace) (current-namespace))])
	  (when prefix
	    (eval prefix n))
	  (lambda (source-files destination-directory)
	    (let ([file-bases (map
			       (lambda (file)
				 (let ([f (extract-base-filename/ss file 'mzc)])
				   (if destination-directory
				       (let-values ([(base file dir?) (split-path f)])
					 (build-path (if (eq? destination-directory 'auto)
							 (let ([d (build-path (if (eq? base 'relative)
										  'same
										  base)
									      "compiled")])
							   (unless (directory-exists? d)
							     (make-directory* d))
							   d)
							 destination-directory)
						     file))
				       f)))
			       source-files)])
	      (for-each
	       (lambda (f b)
		 (let ([zo (append-zo-suffix b)])
		   (compile-to-zo f zo n prefix)))
	       source-files file-bases)))))

      (define (compile-directory dir info zos?)
	(let ([make (c-dynamic-require '(lib "make-unit.ss" "make") 'make@)]
	      [coll (c-dynamic-require '(lib "collection-unit.ss" "make") 'make:collection@)]
	      [init (unit/sig ()
		      (import make^ make:collection^)
		      (values make-collection make-notify-handler))])
	  (let-values ([(make-collection make-notify-handler)
			(invoke-unit/sig
			 (compound-unit/sig
                           (import (DFILE : dynext:file^)
                                   (OPTION : compiler:option^)
                                   (COMPILER : compiler^))
                           (link [MAKE : make^ (make)]
                                 [COLL : make:collection^ (coll MAKE
                                                                DFILE
                                                                OPTION
                                                                COMPILER)]
                                 [INIT : () (init MAKE COLL)])
                           (export))
			 dynext:file^
			 compiler:option^
			 compiler^)])
	    (let ([orig (current-directory)])
	      (dynamic-wind
               (lambda () (current-directory dir))
               (lambda ()
                 (parameterize ([current-load-relative-directory dir])
                   ;; Compile the collection files via make-collection
                   (let ([sses (filter
                                extract-base-filename/ss
                                (directory-list))])
                     (let ([filtered-sses
                            (remove*
                             (map string->path
                                  (info 
                                   (if zos? 
                                       'compile-zo-omit-files 
                                       'compile-extension-omit-files)
                                   (lambda () null)))
                             (remove*
                              (map string->path
                                   (info 'compile-omit-files (lambda () null)))
                              sses))])
                       (if zos?
                           ;; Verbose compilation manager:
                           (parameterize ([manager-trace-handler (lambda (s) (printf "~a~n" s))]
                                          [manager-compile-notify-handler (lambda (path)
                                                                            ((compile-notify-handler) path))])
                             (map (make-caching-managed-compile-zo) filtered-sses))
                           ;; Old collection compiler:
                           (parameterize ([make-notify-handler (lambda (path)
                                                                 ((compile-notify-handler) path))])
                             (make-collection
                              ((or info (lambda (a f) (f)))
                               'name 
                               (lambda () (error 'compile-collection "info did not provide a name in ~e" 
                                                 dir)))
                              filtered-sses
                              (if zos? #("zo") #()))))))))
               (lambda () (current-directory orig)))
	      (when (compile-subcollections)
		(for-each
                 ;; bug! planet files will do the wrong thing here
		 (lambda (s)
		   (unless (and (pair? s) (list? s) (andmap string? s))
		     (error 'compile-collection "bad sub-collection path: ~a" s))
		   (let ((p (apply build-path dir s)))
                     (compile-directory p (get-info/full p) zos?)))
		 (info 'compile-subcollections (lambda () null))))))))
      
      (define (compile-collection cp zos?)
        (let ([dir (apply collection-path cp)]
              [info (c-get-info cp)])
          (compile-directory dir info zos?)))

      (define (compile-collection-extension collection . cp)
	(compile-collection (cons collection cp) #f))
      
      (define (compile-collection-zos collection . cp)
	(compile-collection (cons collection cp) #t))
      
      (define (compile-directory-extension dir info)
        (compile-directory dir info #f))
      
      (define (compile-directory-zos dir info)
        (compile-directory dir info #t))
      
      
      )))
