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

; Accessing packages

(define (environment-ref package name)
  (carefully (package-lookup package name)
	     (lambda (loc)
	       (if (location-assigned? loc)
		   (contents loc)
		   (assertion-violation 'environment-ref "uninitialized variable"
					name package)))
	     package
	     name))

(define (environment-set! package name value)
  (let ((binding (package-lookup package name)))
    (if (and (binding? binding)
	     (not (variable-type? (binding-type binding))))
	(assertion-violation 'environment-set! "invalid assignment" name package value)
	(carefully binding
		   (lambda (loc)
		     (set-contents! loc value))
		   package name))))

(define (environment-define! package name value)
  (set-contents! (package-define! package name usual-variable-type #f #f)
		 value))

(define (*structure-ref struct name)
  (let ((binding (structure-lookup struct name #f)))
    (if binding
	(carefully binding contents struct name)
	(assertion-violation '*structure-ref "name not exported" struct name))))

(define (carefully binding action env name)
  (cond ((not binding)
	 (assertion-violation 'carefully "unbound variable" name env))
	((not (binding? binding))
	 (assertion-violation 'carefully "peculiar binding" binding name env))
	((eq? (binding-type binding) syntax-type)
	 (assertion-violation 'carefully "attempt to reference syntax as variable"
			      name env))
	(else
	 (let ((loc (binding-place binding)))
	   (if (location? loc)
	       (if (location-defined? loc)
		   (action loc)
		   (assertion-violation 'carefully "unbound variable" name env))
	       (assertion-violation 'carefully "variable has no location" name env))))))

; Interaction environment

(define $interaction-environment (make-fluid (make-cell #f)))

(define (interaction-environment)
  (fluid-cell-ref $interaction-environment))

(define (set-interaction-environment! p)
  (if (package? p)
      (fluid-cell-set! $interaction-environment p)
      (assertion-violation 'set-interaction-environment!
			   "invalid package" set-interaction-environment! p)))

(define (with-interaction-environment p thunk)
  (if (package? p)
      (let-fluid $interaction-environment (make-cell p) thunk)
      (assertion-violation 'with-interaction-environment
			   "invalid package" with-interaction-environment p)))

; Scheme report environment.  Should be read-only; fix later.

(define (scheme-report-environment n)
  (if (= n *scheme-report-number*)
      *scheme-report-environment*
      (assertion-violation 'scheme-report-environment
			   "no such Scheme report environment")))

(define *scheme-report-environment* #f)
(define *null-environment* #f)
(define *scheme-report-number* 0)

(define (set-scheme-report-environment! repnum env)
  (set! *scheme-report-number* repnum)
  (set! *scheme-report-environment* env)
  (set! *null-environment* env))		; A cheat.

(define (null-environment n)
  (if (= n *scheme-report-number*)
      *null-environment*
      (assertion-violation 'null-environment
			   "no such Scheme report environment")))

; structs should be a non-null list of structures that should be
; opened at level 1 of the tower.

(define (make-syntactic-tower compile-syntax-node make-lookup-package structs id)
  (vector compile-syntax-node
	  make-lookup-package
	  (list (cons 1 (lambda () structs)))))

(define (package-declarations package)
  (cond
   ((assq 'declare (package-clauses package))
    => cdr)
   (else '())))

; This helps create the make-lookup-package argument for `make-syntactic-tower'.

; The `ensure-instantiated' argument is pretty much always
; `ensure-instantiated' from load-package.scm, but the dependencies
; force us to parameterize.

; This one looks at `no-syntax' and `no-state' declarations:
; `no-state' means that re-instantiation isn't necessary at phase-0.
; `no-syntax' means no macros are exported (it's fine if macros are
; used internally) - both combined means the package never needs to be
; re-instantiated.

(define (make-lookup-package-maker ensure-instantiated)
  (lambda (package)
    (let ((alist '()))
      (lambda (package-0 phase)
	(let ((p (cons package-0 phase))
	      (decls (package-declarations package-0)))
	  (cond
	   ((eq? package package-0) package-0)
	   ((and (memq 'no-state decls)
		 (or (zero? phase)
		     (memq 'no-syntax decls)))
	    package-0)
	   ((assoc p alist) => cdr)
	   (else
	    (let ((new (copy-package package-0 phase
				     ;; make sure the run-time references of `new' get
				     ;; pointed back to `package-0'.
				     (zero? phase))))
	      (set! alist (cons (cons p new) alist))
	      (ensure-instantiated new phase #t (positive? phase))
	      new))))))))

; (set-syntactic-tower-maker! p (lambda (for-syntax-alist id) ...))
; where for-syntaxes is an alist mapping phase levels to promises yielding lists
; of structure names to be accessible at the respective level.

(define set-syntactic-tower-maker!
  (let ((name (string->symbol ".make-syntactic-tower."))
	(name2 (string->symbol ".make-reflective-tower.")))
    (lambda (p proc)
      (environment-define! p name proc)
      ;; backwards compatibility for PreScheme compiler
      (environment-define! p name2 proc))))

; backwards compatibility for PreScheme compiler
(define set-reflective-tower-maker!
  (let ((reader-name (string->symbol ".reader.")))
    (lambda (p proc)
      (set-syntactic-tower-maker! p proc)
      ;; total, utter kludge:
      ;; The reader wasn't configurable in earlier versions of Scheme 48,
      ;; so PreScheme doesn't how to initialize it.
      (if (not (package-lookup p reader-name))
	  (environment-define! p reader-name read)))))

(define set-reader!
  (let ((name (string->symbol ".reader.")))
    (lambda (p reader)
      (environment-define! p name reader))))
