;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

Ï1;;; Copyright (C) 1988 Texas Instruments Incorporated. All rights reserved.

;;;Ï*		Ï2Scheme environment support
Ï1;;;
;;;Ï*Ï*	Ï1This file may be loaded if desired to extend the "Almost Scheme" system
;;;Ï*	Ï1to include limited support for environments as first class objects.
;;;Ï*	Ï1This follows PC Scheme, but has the following limitations:
;;;
;;;Ï*	Ï1 * If Ï3evalÏ* is called with two arguments, the first must be a list or symbol,
;;;Ï*	     Ï1rather than a compiled code object as returned by Ï3compileÏ*.
;;;Ï*	Ï1 * Ï*(Ï3set!Ï* (Ï3accessÏ* id env) value)Ï1   is not yet permitted.
;;;Ï*	Ï1 * Ï3environment-bindingsÏ* and Ï3environment-parentÏ* are inefficient and so 
;;;Ï*	Ï1   Ï*  Ï1should only be used as debugging aids.
;;;Ï*	Ï1 * Ï3procedure-environmentÏ* works for evaluated procedures but not compiled 
;;;Ï*	Ï1   Ï*  Ï1procedures.
;;;Ï*	Ï1 * Environments created in compiled code have just one frame, unlike 
;;;Ï*	Ï1    evaluator environments which have a frame for each binding level.
;;;Ï*	Ï1    Consequently, Ï3environment-bindingsÏ*Ï* Ï1andÏ* Ï3environment-parentÏ1 
;;;Ï*Ï*	Ï1   Ï* Ï1behave differently on compiled code environments than on evaluator 
;;;Ï*	Ï1   Ï* Ï1environments.
;;;Ï*	Ï1* Since, in this implementation, Ï3the-environmentÏ* has to construct an 
;;;Ï*	Ï1    environment object instead of just returning a system data structure 
;;;Ï*	Ï1    Ï*that Ï1already exists, use of environments is less efficient here than 
;;;Ï*	Ï1    in PC Scheme.
;;;
;;  5/13/88 DNG - Original.
;;  5/16/88 DNG
;;  5/19/88 DNG - Added Ï3procedure-environmentÏ*Ï*.
Ï1;;  5/20/88 DNG - Added support for Ï3the-environmentÏ* in compiled code.Ï*

(export '( scheme:environment? scheme:access scheme:unbound?
	  scheme:user-initial-environment scheme:user-global-environment 
	  scheme:the-environment scheme:make-environment
	  scheme:environment-bindings scheme:environment-parent
	  scheme:procedure-environment)
	scheme-package)

(defflavor environment ((local-variables nil) (local-functions nil))
	   () :inittable-instance-variables )
(def-global-scheme-variable scheme:Ï3user-initial-environmentÏ* (make-instance 'environment))
(def-global-scheme-variable scheme:Ï3user-global-environmentÏ* (make-instance 'environment))
(defsubst scheme:Ï3environment?Ï* (object)
  "Is the argument an environment object?"
  (typep object 'environment))

(defun scheme:Ï3evalÏ* (expression &optional (environment nil envp))
  Ï1"Evaluate a Scheme expression."Ï*
  (declare (arglist expression &optional environment))
  (declare (special scheme:user-initial-environment))
  (if envp
      (unless (scheme:environment? environment)
	(cerror "Proceed, using the USER-INITIAL-ENVIRONMENT."
		"The second argument to ~S, ~S, is not an environment object."
		'scheme:eval environment)
	(setq environment scheme:user-initial-environment))
    (setq environment scheme:user-initial-environment))
  (send environment :eval expression))

(defmethod (environment :eval) (expression)
  (LET ((SI:*INTERPRETER-ENVIRONMENT* local-variables)
	(SI:*INTERPRETER-FUNCTION-ENVIRONMENT* local-functions))
    (if (SCHEME-ON-P)
	(SYS:*EVAL expression)
      (with-scheme-on
	(SYS:*EVAL expression)))))

(defmethod (environment :symbol-value) (symbol)
  (LET ((SI:*INTERPRETER-ENVIRONMENT* local-variables)
	(SI:*LISP-MODE* :SCHEME))
    (declare (unspecial SI:*LISP-MODE* SI:*INTERPRETER-ENVIRONMENT*))
    (macrolet ((*eval (expression)
		  `(send self :eval ,expression)))
      (LOOKUP-SYMBOL-VALUE symbol))))

(defmacro scheme:Ï3accessÏ* (&rest args)
  (declare (arglist symbol environment))
  "Returns the value of a variable in a particular environment."
  (if (<= (length args) 2)
      `(symbol-value-in-environment ',(first args) ,(second args))
    `(scheme:access ,(first args) (scheme:access . ,(rest args)))))

(defun symbol-value-in-environment (symbol environment)
  (check-type environment environment)
  (send environment :symbol-value symbol))

(defmacro scheme:Ï3unbound?Ï* (symbol &rest more)
  (declare (arglist symbol &optional environment))
  (if (null more)
      `(not (or (variable-boundp ,symbol)
		(fboundp ',symbol)))
    (if (null (rest more))
	`(not (or (fboundp ',symbol)
		  (scheme:eval '(variable-boundp ,symbol)
			       ,(first more))))
      `(scheme:unbound? ,symbol (scheme:access . ,more)))))

(defun scheme:Ï3the-environmentÏ* ()Ï1 ; note this version used only in the evaluator.Ï*
  Ï1"Returns the current lexical environment."Ï*
  (declare (special scheme:user-initial-environment))
  (if (and (null *interpreter-environment*)
	   (null *interpreter-function-environment*))
      scheme:user-initial-environment
    (make-instance 'environment
		   :local-variables (copy-list-into-heap *interpreter-environment*)
		   :local-functions (copy-list-into-heap *interpreter-function-environment*))))

(defun (:property scheme:Ï3the-environmentÏ* compiler:p1) (form)
  (if (or (rest form)Ï1 ; too many arguments; let it get error at runtime.Ï*
	  (null compiler:p1value)Ï1 ; value not used anywayÏ*
	  (zerop compiler:1-if-live-code))
      (compiler:p1evargs form)
    (let ((varlist '())
	  (namelist '()))
      (dolist (v compiler:vars)
	(let ((name (compiler:var-name v)))
	  (when (and (symbolp name)
		     (symbol-package name)
		     (eq (compiler:var-type v) 'compiler:fef-local)
		     (eq v (compiler:lookup-var name))
		     (not (eq name 'compiler:|Exit block NIL|)))
	    Ï1;; local variable that is not shadowed.Ï*
	    (push name namelist)
	    (push nil varlist)
	    (push `(locally (declare (special ,name))
			    (variable-location ,name))
		  varlist))))
      (if (null varlist)
	  (compiler:p1 'scheme:user-initial-environment)
	(let ((updates '()))
	  (do ((i 1 (+ i 2))
	       (names namelist (rest names)))
	      ((null names))
	    (push `(sys:%p-store-tag-and-pointer
		     (locf (nth ,i varlist))
		     (DPB ,(if (null (rest names)) sys:cdr-nil sys:cdr-next)
			  #.(BYTE (BYTE-SIZE sys:%%Q-Cdr-Code)
				  (BYTE-SIZE sys:%%Q-Data-Type))
			  sys:dtp-external-value-cell-pointer)
		     (variable-location ,(first names)))
		  updates))
	  (let ((fn (compiler:p1v
		      Ï1;; do it this way so that the closure is not considered ephermeral.Ï*
		      `(function (named-lambda scheme:the-environment ()
				    (make-instance 'sys:environment
						   :local-variables
						   (list (let ((varlist (list . ,varlist)))
							   ,.updates
							   varlist))
						   ;; :local-functions nil
						   ))))))
	    (compiler:p1
	      (let ((g (gensym)))
		`(let ((the-environment (compiler:undefined-value)))
		   (or the-environment
		       (let ((,g ,(compiler:mark-p1-done fn)))
			 (tagbody ,g Ï1; just to force the Ï*UNSHAREÏ1 to be emitted by pass 2Ï*
			     (compiler:unshare-stack-closure-vars . ,namelist)
			     (or (setq the-environment (funcall ,g ))
				 (go ,g) Ï1; just so the tagbody isn't optimized away.Ï*
				 ))
			 the-environment))))
	      t)))))))

(defmacro scheme:Ï3make-environmentÏ* (&body expressions)
  Ï1"Create an environment object."Ï*
  `(scheme:let ()
     ,@expressions
     (scheme:the-environment)))

(defsubst scheme:Ï3environment-bindingsÏ* (environment)
  Ï1"Convert the first frame of Ï*ENVIRONMENTÏ1 into an a-list."Ï*
  (send environment :environment-bindings))

(defmethod (environment :environment-bindings) ()
  (let ((bindings '()))
    (do ((tail (first local-variables) (cddr tail)))
	((null tail))
      (push (cons (%FIND-STRUCTURE-HEADER (first tail))
		  (second tail))
	    bindings))
    bindings))

(defsubst scheme:Ï3environment-parentÏ* (environment)
  (send environment :environment-parent))

(defmethod (environment :environment-parent) ()
  (declare (special scheme:user-initial-environment))
  (if (and (null local-variables)
	   (null local-functions))
      nil
    (if (and (null (rest local-variables))
	     (null (rest local-functions)))
	scheme:user-initial-environment
      (make-instance 'environment :local-variables (rest local-variables)
		     :local-functions (rest local-functions)))))

(defun scheme:Ï3procedure-environmentÏ* (procedure)
  Ï1"Return the environment closed over by a procedure."Ï*
  (let ((dtp (%data-type procedure)))
    (declare (special scheme:user-initial-environment))
    (case dtp
      (#.dtp-closure				Ï1; interpreted closureÏ*
       (make-instance 'environment
		      :local-variables
		      (symeval-in-closure procedure '*interpreter-environment*)
		      :local-functions
		      (symeval-in-closure procedure '*interpreter-function-environment*)))
      (#.dtp-lexical-closure			Ï1; compiled closureÏ*
       (error "Compiled functions are not supported by ~S."
	      'scheme:procedure-environment))
      Ï1;; else not a closureÏ*
      ((#.dtp-function #.dtp-u-entry) scheme:user-initial-environment)
      (t (unless (functionp procedure t)
	   (cerror "Continue, returning global environment."
		   "The argument to ~S is ~S, which is not a procedure."
		   'scheme:procedure-environment procedure))
	 scheme:user-initial-environment) )))
