;;;-*- 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-parent1 
;;;**	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 *UNSHARE1 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 *ENVIRONMENT1 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) )))