; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

(define (compile-package package)
  (check-package-for-duplicates! package)
  (call-with-lookup-package
   ((package-make-lookup-package package) package)
   (lambda ()
     (receive (expanded for-syntax) (expand-package package)
       (walk-population check-structure
			(package-clients package))
       (let ((name (package-name package))
	     (uid (package-uid package)))
	 (set-package-invoke-template! package
				       (compile-forms ((get-optimizer 
							(if (package-integrate? package)
							    (package-optimizers package)
							    '()))
						       expanded
						       package)
						      name uid))
	 (set-package-visit-template! package
				      (compile-syntax-forms for-syntax name uid))
	 (set-package-visited?! package #t))))))

; First we map down the FORMS+FILES, adding the filenames to ENV and
; scanning the forms.  Then we walk down the list of scanned forms and
; expand all the macros.
;
; All of the reversing in the second step makes it so that we process the
; forms in there original order, to keep any errors or warnings in as
; appropriate an order as possible, and then return them in their original
; order.

(define (expand-package package)
  (let ((env (package->environment package))
	 (forms+files (package-source package)))
    (define-usual-transforms package)
    ((or (package-expander package)
	 expand-forms) ; default expander
     env
     (if (package-all-operators? package)
	 `((#f . ,(define-primitives env))
	   . ,forms+files)
	 forms+files))))

; This adds definitions of all operators to ENV and returns a list of forms
; that define the closed-compiled versions of those operators that have such.
; It also adds a definition of ALL-OPERATORS to a vector of all the primitive
; operators, mostly for later use by the debugger to identify which primop
; caused an exception.

(define (define-primitives env)

  (define-operators env)

  (comp-env-define! env 'all-operators vector-type)
  
  (let ((p (comp-env-package env)))

    (define (wrap e)
      (in-package-context p 0 e))

    (let ((vector-set!-stx (make-node operator/literal (get-primop 'vector-set!)))
	  (procs '())
	  (index 0))

      (define (make-define-primitive-node name env)
	(wrap `(,syntax/define ,name
			       (,syntax/primitive-procedure ,name))))

      (define (make-register-primitive name index env)
	(wrap `((,syntax/code-quote ,(get-primop 'vector-set!)) ; hack
		all-operators
		,index
		,name)))
		
      (walk-primops (lambda (name type primop)
		      (comp-env-define! env name type primop)
		      (set! procs
			    (cons (make-define-primitive-node name env)
				  (cons
				   (make-register-primitive name index env)
				   procs)))
		      (set! index (+ 1 index))))

      (cons
       (wrap
	`(,syntax/define all-operators
			 ((,syntax/code-quote ,(get-primop 'make-vector))
			  ,index)))
       procs))))

(define (define-operators env)
  (table-walk (lambda (name op)
		(let ((type (operator-type op)))
		  (if (and (not (eq? (operator-type op) 'leaf))
			   (not (lookup env name))) ; there might be a usual-macro already sitting there
		      (comp-env-define! env name (operator-type op) op))))
	      operators-table))
