;;; -*-  Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB HL12BI); Base:10; Patch-file:T -*-

;;; Copyright (C) 1987 Texas Instruments Incorporated. All rights reserved.


Ï2;;;  Ï*         Ï2Evaluator changes to support Scheme.Ï*



(Defmacro LOOKUP-SYMBOL-VALUE (symbol)
  ;; 10/18/87 DNG - Changed (COMMON-LISP-ON-P) to (NOT (ZETALISP-ON-P)) for correct operation in Scheme mode.
  ;; 11/14/87 DNG - Add support for SCHEME:DEFINE-INTEGRABLE .
  `(IF (NOT (ZETALISP-ON-P))
       (LET ((vcell (LOCF (SYMBOL-VALUE ,symbol))))
	 (DOLIST (frame *INTERPRETER-ENVIRONMENT*
			(IF (AND (SCHEME-ON-P)
				 (NOT (BOUNDP ,symbol)))
			    (IF (AND (NOT (FBOUNDP ,SYMBOL))
				     (SETQ VCELL (GET ,SYMBOL 'COMPILER:INTEGRABLE)))
				(*EVAL VCELL)
			      (SYMBOL-FUNCTION ,symbol))
			  (SYMBOL-VALUE ,symbol)))
	   (LET ((value (GET-LOCATION-OR-NIL (LOCF frame) vcell)))
	     (WHEN value (RETURN (CAR value))))))
       (SYMBOL-VALUE ,symbol)))


;;;PHD 1/19/87 Returns second value: T when the symbol was found locally  
;;;DNG 10/18/87 Added handling for Scheme mode.
(Defmacro LOOKUP-FUNCTION-DEFN (symbol)
  `(IF *INTERPRETER-FUNCTION-ENVIRONMENT*
       (LET ((vcell (LOCF (SYMBOL-FUNCTION ,symbol))))
	 (DOLIST (frame *INTERPRETER-FUNCTION-ENVIRONMENT* (SYMBOL-FUNCTION ,symbol))
	   (LET ((value (GET-LOCATION-OR-NIL (LOCF frame) vcell)))
	     (IF value (RETURN (values (CAR value) t))))))
     (BLOCK LOOKUP
       (WHEN (SCHEME-ON-P)
	 (WHEN *INTERPRETER-ENVIRONMENT*
	   (LET ((vcell (LOCF (SYMBOL-VALUE ,symbol))))
	     (DOLIST (frame *INTERPRETER-ENVIRONMENT* )
	       (LET ((value (GET-LOCATION-OR-NIL (LOCF frame) vcell)))
		 (WHEN value (RETURN-FROM LOOKUP (CAR value)))))) )
	 (UNLESS (FBOUNDP ,SYMBOL)
	   (LET ((VALUE (GET ,SYMBOL 'COMPILER:INTEGRABLE)))
	     (WHEN VALUE
	       (RETURN-FROM LOOKUP (*EVAL VALUE))))))
       (SYMBOL-FUNCTION ,symbol))))

(unless (boundp '*INTERPRETER-EXTRA-ENVIRONMENT*) ; new in release 6
  (setq *INTERPRETER-EXTRA-ENVIRONMENT* nil))

;;PAD 1/16/87 Removed closure following in the do-forever loop. Fixes SPR 2984.
;;PHD 1/19/87 Bind *INHIBIT-DISPLACING-FLAG* to T when the macro function comes from a macrolet
;;PHD 2/12/87 Use copy-list-into-heap for safe use of the environment by user hooks.
;;AB for PHD 6/19/87 Allow QUOTE-DEGREE of NIL in compiled special forms (for &FUNCTIONAL arguments).  SPR 5642.
;;DNG 12/5/87 Modified for Scheme -- allow arbitrary expression as CAR of form.
;;DNG 4/22/89 Add use of *INTERPRETER-EXTRA-ENVIRONMENT* in the hook environment.

(Defun *EVAL (form)
Ï1;;; Internal evaluator which evaluates <form> in the current lexical environment , as defined by
;;; the special variables *interpreter-environment* and *interpreter-function-environment*. All values
;;; of <form> are returned.Ï*
  
  (WHEN  (AND *EVALHOOK* (NOT (PROG1 *SKIP-EVALHOOK* (SETQ *SKIP-EVALHOOK* nil))))
    (RETURN-FROM *EVAL
      (LET ((hook-function *EVALHOOK*) *EVALHOOK*
	    (*INTERPRETER-ENVIRONMENT* (copy-list-into-heap *INTERPRETER-ENVIRONMENT* ))
	    (*INTERPRETER-FUNCTION-ENVIRONMENT* (copy-list-into-heap *INTERPRETER-FUNCTION-ENVIRONMENT*  )))
	(WITH-STACK-LIST*
	  (env *INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT* *INTERPRETER-EXTRA-ENVIRONMENT*)
	  (FUNCALL hook-function form env)))))
  
  (WHEN (ATOM form)
    (RETURN-FROM *EVAL
      (IF (SYMBOLP form)
	  (LOOKUP-SYMBOL-VALUE form)
	  form)))
  
  (WHEN (and (EQ (CAR form) 'QUOTE)
	     (= (length form) 2))
    (RETURN-FROM *EVAL (CADR form)))
  
  (LET ((function-obj (CAR form)) special-form-arglist local dbi quote-degree)
   (block fun-type
    (TYPECASE function-obj
      (list
       (let (lambda-name lambda-body)
	 (COND
	   ((NAMED-LAMBDA-P (CAR function-obj))
	    Ï1;; for named-lambda's, arglist is in third positionÏ*
	    (WHEN (MEMBER '&QUOTE (CADDR function-obj) :test #'eq)
	      (SETQ special-form-arglist (CADDR function-obj)))Ï1  Ï*
	    (setq lambda-name (second function-obj))
	    (setq lambda-body (cddr function-obj)))
	   ((ANONYMOUS-LAMBDA-P (CAR function-obj))
	    Ï1;; for lambda's, arglist is in second positionÏ*
	    (WHEN (MEMBER '&QUOTE (CADR function-obj) :test #'eq)
	      (SETQ special-form-arglist (CADR function-obj)))Ï1 Ï*   
	    (setq lambda-body (cdr function-obj)))
	   ((and (consp function-obj)
		 (SCHEME-ON-P))
	    (setq function-obj (*EVAL function-obj))
	    (return-from fun-type))
	   (t (SI:INVALID-FUNCTION form)))
	 (return-from *eval
	   Ï1;; step 3 -- process args and callÏ*
	   (with-stack-list* (fun 'closure-named-lambda lambda-name lambda-body)
	     (IF special-form-arglist
		 (INVOKE-SPECIAL-FORM fun special-form-arglist (CDR form))Ï1   Ï*
		 (INVOKE-FUNCTION fun (CDR form)))))))
      (symbol   ;; move through symbols and deff's
       (multiple-value-setq (function-obj local)
	 (LOOKUP-FUNCTION-DEFN function-obj))
       )))
   (do () ((not (symbolp function-obj)))
     (setf function-obj  (symbol-function function-obj)))
    
    (TYPECASE function-objÏ1 Ï* ;; see if function-obj is a special form. If so, get the arglist.
      (list
       (COND
	 ((EQ (CAR function-obj) 'MACRO)
	  (RETURN-FROM *EVAL
	    (*EVAL (let-if local
			   ((*INHIBIT-DISPLACING-FLAG* t))
		     (SI:MACROEXPAND-AND-MAYBE-DISPLACE (CDR function-obj) form)))))
	 ((NAMED-LAMBDA-P (CAR function-obj))
	  Ï1;; for named-lambda's, arglist is in third positionÏ*
	  (WHEN (MEMBER '&QUOTE (CADDR function-obj) :test #'eq)
	    (SETQ special-form-arglist (CADDR function-obj))))
	 ((ANONYMOUS-LAMBDA-P (CAR function-obj))
	  Ï1;; for lambda's, arglist is in second positionÏ*
	  (WHEN (MEMBER '&QUOTE (CADR function-obj) :test #'eq)
	    (SETQ special-form-arglist (CADR function-obj))))
	 (t (SI:INVALID-FUNCTION form))))
      (compiled-function
       (WHEN (COMPILED-SPECIAL-FORM? function-obj)
	 (SETQ dbi (EXTRACT-DEBUG-INFO-STRUCT-FROM-FEF function-obj)
	       ;; see debug-info for meaning of :quote-degree
	       quote-degree (GETF (DBI-PLIST dbi) :quote-degree)) 
	 (UNLESS (AND quote-degree (ZEROP quote-degree))	;PHD
	   (SETQ special-form-arglist (DBI-ARGLIST dbi))))))
    
    Ï1;; step 3 -- process args and callÏ*
    (IF special-form-arglist
	(INVOKE-SPECIAL-FORM function-obj special-form-arglist (CDR form))
	(IF quote-degree
	    (APPLY function-obj (CDR form))
	    (INVOKE-FUNCTION function-obj (CDR form))))
    ))


(defun scheme:Ï1set!Ï* (&quote variable expression)
  "Set VARIABLE to the value of EXPRESSION."
  (declare (arglist &quote variable &eval expression))
  (let ((destination variable))
    (UNLESS (SYMBOLP destination)
      (setq destination (macroexpand destination))
      (when (consp destination) ;  permitted by PC Scheme although not by Revised^3 Report
	(case (first destination)
	  (symbol-value
	   (return-from scheme:set! (set (*eval (second destination)) (*eval expression))))
	  (aref (return-from scheme:set!
		  (setf (aref (*eval (second destination)) (*eval (third destination)))
		      (*eval expression))))
	  (function (let ((value (*eval expression)))
		      (fdefine (second destination) value t)
		      (return-from scheme:set! value)))))
      (unless (symbolp destination)
	(FERROR nil "SET! with invalid destination: ~S" variable)))
    (WHEN (MEMBER destination '(t nil) :TEST #'EQ)
      (FERROR nil "attempted to SET! the constant ~s" variable))
    (let ((VALUE (*EVAL expression)))
      (block INTERPRETER-SET
	(LET ((vcaddress (LOCF (SYMBOL-VALUE destination))))	; get value cell address
	  (DOLIST (frame *INTERPRETER-ENVIRONMENT*
			 (progn (unless (fboundp destination)
				  (if (get destination 'special)
				      (progn (set destination value) (return-from INTERPRETER-SET))
				    (cerror "Define it globally and continue."
					    "SET! of ~S which is not a bound variable."
					    destination)))
				(if (member (symbol-package destination)
					    '#,(list *lisp-package* *ticl-package* *zlc-package*)
					    :test #'eq)
				    (fdefine destination value t)	; to get redefinition query
				  (FSET destination value))) )
	    (LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) vcaddress)))
	      (IF slot (RETURN (SETF (CAR slot) value)))))))
      VALUE ; officialy the result is undefined, but return the value for PC Scheme compatibility.
      )))

(defun with-scheme-semantics (&quote &rest body)
  "Evaluate the body forms according to Scheme instead of Common Lisp.
Returns the value of the last form."
  ;; 12/12/87 DNG - Original version.
  (LET ((SI:*LISP-MODE* :SCHEME))
    (EVAL-BODY-AS-PROGN body)))

(defun compiler:unshare-stack-closure-vars (&quote &rest variables) ; %%% how to do this???
  (comment
    (cerror "Continue without unsharing."
	    "~A is not yet implemented in the evaluator."
	    'compiler:unshare-stack-closure-vars)
    )
  variables
  (values))


;;PHD-PAD 1/21/87 Fixed it so it follows symbol-function being symbols (see locally).
;;DNG 3/09/88 Fixed to correctly handle a function value of NIL [treat as 
;;	symbol instead of list]. [SPR 7452]
;;DNG 3/21/88 Fixed to not error on definition which is a cons but not a function.
(DEFUN SPECIAL-FORM-P (symbol)
  "a predicate returning t if <symbol> has a function definition whose lambda list contains &quote."
  (WHEN (FBOUNDP symbol)
    (LET ((fct-binding (SYMBOL-FUNCTION symbol)))
      (TYPECASE fct-binding
	(compiled-function
	 (COMPILED-SPECIAL-FORM? fct-binding))
	(cons
	 (IF (EQ (CAR fct-binding) 'macro) 
	     nil
	     (AND (MEMBER (CAR fct-binding) function-start-symbols :TEST #'EQ)
		  (MEMBER '&QUOTE (ARGLIST fct-binding t) :test #'EQ) 
		  t)))
	(symbol (special-form-p fct-binding))
	))))

(defun scheme:fluid-let (&quote bindings &rest body)
  "Bind fluid variables"
  ;;  3/21/88 DNG - Original (previously a macro).
  ;; This is similar to PROGW except that the bindings must be done in parallel.
  (let ((count 0))
    (do ((vars-and-vals bindings (cdr vars-and-vals)))
	((null vars-and-vals))
      (%push (value-cell-location (caar vars-and-vals)))
      (%push (*EVAL (cadar vars-and-vals)))
      (incf count))
    (tagbody ; can't use DO because it would undo bindings at the end.
     next
	(when (<= count 0) (go done))
	(%bind (%pop) (%pop))
	(decf count)
	(go next)
     done)
    (EVAL-BODY-AS-PROGN body) ))

(setf (get 'scheme:fluid-let 'zwei:lisp-indent-offset)
      (get 'lisp:let 'zwei:lisp-indent-offset))