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

; Compile-time environments
; These are functions
;  name -> node			; lexical variable
;          binding              ; package variable, any syntax
;          #f			; free
;
; Special names are used to retrieve various values from compiler environments.

(define-record-type compiler-specials :compiler-specials
  (make-compiler-specials lookup define! package phase source-file-name)
  compiler-specials?
  (lookup compiler-specials-lookup)
  (define! compiler-specials-define!)
  (package compiler-specials-package)
  (phase compiler-specials-phase)
  (source-file-name compiler-specials-source-file-name))

(define-record-type compiler-env :compiler-env
  (really-make-compiler-env specials alist)
  compiler-env?
  (specials compiler-env-specials)
  (alist compiler-env-alist))

(define-record-discloser :compiler-env
  (lambda (r)
    (list 'compiler-env
	  (comp-env-package r)
	  (comp-env-phase r))))

(define (lookup cenv name)
  (cond
   ((assq name (compiler-env-alist cenv)) => cdr)
   (else
    (let ((specials (compiler-env-specials cenv)))
    ((compiler-specials-lookup specials) name (compiler-specials-phase specials))))))

; Note that clients assume that the bindings get layered on top of the
; old ones; the old ones don't get elided.  See comp-env-filter below.
(define (bind1 name binding cenv)
  (really-make-compiler-env (compiler-env-specials cenv)
			    (cons (cons name binding) (compiler-env-alist cenv))))

(define (bind names bindings cenv)
  (really-make-compiler-env (compiler-env-specials cenv)
			    (append (map cons names bindings)
				    (compiler-env-alist cenv))))

; filters the local bindings only
; proc takes a name and its binding
(define (comp-env-filter proc cenv)
  (really-make-compiler-env (compiler-env-specials cenv)
			    (filter (lambda (p)
				      (proc (car p) (cdr p)))
				    (compiler-env-alist cenv))))

; Making the initial compiler environment.
;
;  lookup : name phase -> binding or (binding . path) or #f
;  define! : name type [static] -> void
;  macro-compile-syntax-node : 
;     <name> <node> <env> -> <template-or-#f> <thunk>, evaluator for syntax-transformer nodes
;  macro-package-promise : promise of package for syntax transformers

(define (make-compiler-env lookup define! package . phase-option)
  (let ((phase (if (pair? phase-option)
		   (car phase-option)
		   0)))
    (really-make-compiler-env (make-compiler-specials lookup define! 
						      package phase #f)
			      '())))

; Function for adding definitions to the outer package.

(define (comp-env-define! cenv name type . maybe-value)
  (apply (compiler-specials-define! (compiler-env-specials cenv))
	 name type maybe-value))

; The package on which the compiler environment is based.  This is a
; temporary hack to keep the package-editing code working.

(define (comp-env-package cenv)
  (compiler-specials-package (compiler-env-specials cenv)))

; The name of the source file.
;   This is used by the %FILE-NAME% special form,
;   which is in turn used by the (MODULE ...) form to save the current file in
;    each package, 
;   which is (finally) used to look up filenames in the correct directory.

(define (bind-source-file-name filename env)
  (if filename
      (let ((specials (compiler-env-specials env)))
	(really-make-compiler-env (make-compiler-specials 
				   (compiler-specials-lookup specials)
				   (compiler-specials-define! specials)
				   (compiler-specials-package specials)
				   (compiler-specials-phase specials)
				   filename)
				  (compiler-env-alist env)))
      env))

(define (source-file-name cenv)
  (compiler-specials-source-file-name (compiler-env-specials cenv)))

(define (comp-env-phase cenv)
  (compiler-specials-phase (compiler-env-specials cenv)))

(define (comp-env-bump-phase cenv n)
  (if (zero? n)
      cenv
      (really-comp-env-bump-phase cenv n)))

(define (really-comp-env-bump-phase cenv n)
  (let ((specials (compiler-env-specials cenv)))
    (really-make-compiler-env (make-compiler-specials
			       (compiler-specials-lookup specials)
			       (compiler-specials-define! specials)
			       (compiler-specials-package specials)
			       (+ n (compiler-specials-phase specials))
			       (compiler-specials-source-file-name specials))
			      '())))

(define (comp-env-next-phase cenv)
  (comp-env-bump-phase cenv 1))
