1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-


;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;*
;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.

;;; macros common to all files comprising the evaluator system*
(PROCLAIM '(SPECIAL *keyword-package*))
;;
;; DEFINITION OF THE LEXICAL ENVIRONMENT
;;
;;  maintained in the two special variables *INTERPRETER-ENVIRONMENT* and
;;  *INTERPRETER-FUNCTION-ENVIRONMENT* 
;;
;;  *INTERPRETER-ENVIRONMENT* stores variable bindings, BLOCK names and GO tags
;;  as a list of frames.
;;  -- a frame binding the variables var1,...,varN looks like
;;               (locvar1 val1 ... locvarN valN) 
;;         where
;;               locvar1,...,locvarN denote LOCATIVES to the variables
;;         and
;;               val1,...,valN denote their respective values
;;         If a variable varI is declared special or has the property SPECIAL, then
;;         the actual value is stored in the symbol's value cell and valI is a
;;         DTP-EXTERNAL-VALUE-CELL-POINTER to the value cell.
;;  -- a frame defining a block name looks like (BLOCK name-of-block pointer)
;;         where pointer points to the start of the frame. (See ENTER-BLOCK).
;;  -- a frame defining a sequence of go tags looks like 
;;               (TAG pointer TAG1 BODY1 ... TAGN BODYN)
;;         where pointer serves the same function as in block frames and BODYI
;;         is the list of forms to be executed when (GO TAGI) is executed.
;;
;;  *INTERPRETER-FUNCTION-ENVIRONMENT* stores local function and macro definitions
;;  as a list of frames. Such frames are constructed by FLET,MACROLET and LABELS.

(Defvar *INTERPRETER-ENVIRONMENT* nil
1   "The current lexical environment for evaluation - hands off !!!")*

(Defvar *INTERPRETER-FUNCTION-ENVIRONMENT* nil
1  "the current lexical environment for local function and macro definitions - hands off !!!")*

;; 4/11/89 DNG - New variable.
(Defvar *INTERPRETER-EXTRA-ENVIRONMENT* nil) ; additional info for macroexpand environments, not used by EVAL itself.

;; Old names
(Defvar INTERPRETER-ENVIRONMENT nil)
(Defvar INTERPRETER-FUNCTION-ENVIRONMENT nil)

;; 4/11/89 DNG - Reversed the forwarding to indirect the old symbol to the new one.
(FORWARD-VALUE-CELL 'INTERPRETER-ENVIRONMENT '*INTERPRETER-ENVIRONMENT*)
(FORWARD-VALUE-CELL 'INTERPRETER-FUNCTION-ENVIRONMENT '*INTERPRETER-FUNCTION-ENVIRONMENT*)

;; 4/11/89 DNG - Original.
(defmacro with-interpreter-environment ((variable vars functions &optional extra) &body body)
  "Execute BODY with VARIABLE bound to an environment constructed from VARS, FUNCTIONS, and EXTRA."
  `(WITH-STACK-LIST* (,variable ,vars ,functions ,extra)
    . ,body))

(Defmacro EVAL-BODY-AS-PROGN (bodyvar)
  `(IF (NULL ,bodyvar) nil
     (DO ((L ,bodyvar (CDR L)))
	 ((NULL (CDR L)) (*EVAL (CAR L)))
       (*EVAL (CAR L)))))

(Defmacro VARIABLE-P(symbol)
 `(AND (SYMBOLP ,symbol)
       (NOT (MEMBER ,symbol '(t nil) :TEST #'EQ))
       (NEQ (SYMBOL-PACKAGE ,symbol) *KEYWORD-PACKAGE*)
       (NOT (GET ,symbol 'COMPILER:SYSTEM-CONSTANT))))

(Defmacro SPECIAL-VAR-P (symbol list-of-specials)
 `(OR (GET ,symbol 'SPECIAL) (MEMBER ,symbol ,list-of-specials :TEST #'EQ)))

(Defmacro LAMBDA-LIST-KEYWORD-P (sym)
  `(MEMBER ,sym LAMBDA-LIST-KEYWORDS :test #'EQ))

(Defmacro NAMED-LAMBDA-P (sym)
  `(MEMBER ,sym '(NAMED-LAMBDA NAMED-SUBST GLOBAL:NAMED-LAMBDA GLOBAL:NAMED-SUBST) :test #'EQ))

(Defmacro ANONYMOUS-LAMBDA-P (sym)
  `(MEMBER ,sym '(CLI:LAMBDA GLOBAL:LAMBDA CLI:SUBST GLOBAL:SUBST) :test #'EQ))


1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; EXTRACT-SPECIAL-DECLARATIONS
;; 
;;  Assumes BODY is locally bound in the caller and has the form 
;;     (["..."][(declare...)].rest)
;;  where "..." denotes the optional documentation string. Returns a list
;;  of all variables declared SPECIAL. This macro changes BODY by 1) removing 
;;  the documentation string, 2) by removing declarations and 3) by expanding
;;  macros found while searching for declarations. Also observe that the macro
;;  performs CONSING proportional to the number of variables declared SPECIAL.
;;
;;  the macro is taken from the *SPICE LISP* implementation written by Fahlman et al.*
;;PHD 2/17/87 Fixed it by defining local-macro-function.
(defmacro local-macro-function (symbol)
  `(LET* ((faddress (LOCF (SYMBOL-FUNCTION ,symbol)))
	  (definition  (DOLIST (frame *INTERPRETER-FUNCTION-ENVIRONMENT* (declared-definition ,symbol))
			 (LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) faddress)))
			   (WHEN slot (RETURN (CAR slot)))))))
     (and (eq 'macro (car-safe definition))
	  (cdr definition))))

(DEFMACRO EXTRACT-SPECIAL-DECLARATIONS ()
 "Examines a special form or a lambda expression, everything after the
  argument list, and returns a list (var1 ... varN) of variables declared
  SPECIAL."

 `(DO ((b body (CDR b))
       (specials nil)
       (form))
      ((ATOM b) (SETQ body b) (RETURN specials))
    (SETQ form (car b))
    (COND
      ((AND (STRINGP form) (CDR b)) (GO SKIP))  ;; treat form as doc string
      ((NOT (consp form))
       (SETQ body b) (RETURN specials))
      ((EQ (CAR form) 'declare))
      ((AND (SYMBOLP (CAR form))
	    (local-macro-function (car form))
	    (SETQ form (with-interpreter-environment (environment nil *INTERPRETER-function-ENVIRONMENT* )
			 (macroexpand form environment))))
       (UNLESS (AND (CONSP form)(EQ (CAR form) 'declare)) 
	 (RETURN specials)))
      (t (SETQ body b) (RETURN specials)))
    (DO ((x (CDR form) (CDR x)))
	((ATOM x))
      (AND 
	(LISTP (CAR x)) 
	(EQ (CAAR x) 'special)
	(DO ((v (CDAR x) (CDR v)))
	    ((ATOM v))
	  (PUSH (CAR v) specials))))
    SKIP))


;1; generate code to bind variables in parallel as in a LET,PROG,DO*
(defmacro with-parallel-basic-frame ((varlist specials) &body body)
  `(let* ((spec-ref-bframe (%make-stack-list (* 2 (length ,specials))))
	 (bframe (%make-stack-list (* 2 (length ,varlist))))
	 newenv)
     (do ((x ,specials (cdr x))1  ;; add declared special vars to frame*
	  (b spec-ref-bframe  (cddr b))
	  var)
	 ((atom x)
	  (let-if (and spec-ref-bframe
		       (setf newenv (%make-explicit-stack-list* spec-ref-bframe  *interpreter-environment*)))
		  ((*interpreter-environment* newenv))
	    (do ((b bframe (cddr b))1   ;; PASS 1 - compute the values of the variables to be bound*
		 (v ,varlist (cdr v)))
		((atom v))
	      (when (consp (car v))(setf (second b) (*eval (cadar v)))))
	    (do ((b bframe (cddr b))1   ;; PASS 2 - perform the binding*
		 (v ,varlist (cdr v)))
		((atom v)
		 (let-if (and bframe (setf newenv (%make-explicit-stack-list* bframe *interpreter-environment*)))
			 (( *interpreter-environment* newenv))
		   . , body))
	      (setq var (if (consp (car v)) (caar v) (car v)))
	      (unless (variable-p var) (binding-error var))
	      (when (special-var-p var ,specials)
		(bind (value-cell-location var) (cadr b))
		(%p-store-data-type-and-pointer
		  (locf (cadr b)) dtp-external-value-cell-pointer (value-cell-location var)))
	      (setf (first b) (value-cell-location var)))))
       (setq var (car x))
       (unless (symbolp var) (binding-error var))
       (setf (car b) (value-cell-location var))
       (%p-store-data-type-and-pointer
	 (locf (cadr b)) dtp-external-value-cell-pointer (value-cell-location var))
       )))

;;PHD 3/11/87 Follow forwarding from stack-list to heap.
(DEFMACRO WITH-SERIAL-BASIC-FRAME ((varlist specials) &BODY body)
;1; generate code to bind variables serially as in a LET*,PROG*,DO**
;1; the binding frame is constructed in reverse so that the most recent binding of a variable*
;1; will always bethe first one found*
    `(LET* ((varlist-len (* 2 (LENGTH ,varlist)))
	    (bframe (%MAKE-STACK-LIST (+ varlist-len (* 2 (LENGTH ,specials)))))
	    (loc (%POINTER bframe)) newenv)
       (let-if (and bframe (setf newenv (%make-explicit-stack-list* bframe *INTERPRETER-ENVIRONMENT*)))
	       ((*INTERPRETER-ENVIRONMENT* newenv))
	 (DO ((x ,specials (CDR x))1  ; add declared special vars to frame*
	      (b bframe (CDDR b)) var)1 *
	     ((ATOM x)
	      (DO* ((b b (CDDR b))1   ; continue in bframe where we left off*
		    1;; compute values and bind variables*
		    (bframe-ptr (- (+ varlist-len (* 2 (LENGTH ,specials))) 2) (- bframe-ptr 2))
		    (slot (%MAKE-POINTER DTP-LIST (+ loc bframe-ptr)) (%MAKE-POINTER DTP-LIST (+ loc bframe-ptr)))
		    (v ,varlist (CDR v)))
		   ((ATOM v)
		    (PROGN . ,body))
		(COND 
		  ((CONSP (CAR v))
		   (SETQ var (CAAR v))
		   (SETF (CADR slot) (*EVAL (CADAR v))))
		  (t
		   (SETQ var (CAR v))))
		(IF (VARIABLE-P var) (SETF (CAR slot) (VALUE-CELL-LOCATION var))
		    (BINDING-ERROR var))
		(WHEN (SPECIAL-VAR-P var ,specials)
		  (BIND (VALUE-CELL-LOCATION var) (CADR slot))
		  ;;Beware of the fact that the list might be copied into the heap
		  ;;At that point because we called *eval earlier.
		  ;;Follow to the real list.
		  (%p-store-data-type-and-pointer
		    (if (/= DTP-EXTERNAL-VALUE-CELL-POINTER (%p-data-type (locf (SECOND slot))))
			(locf (second slot))
			(%P-CONTENTS-AS-LOCATIVE (locf (second slot))))
		    DTP-EXTERNAL-VALUE-CELL-POINTER (VALUE-CELL-LOCATION var))
		  )))
	   (SETQ var (CAR x))
	   (UNLESS (SYMBOLP var) (BINDING-ERROR var))
	   (SETF (FIRST b) (VALUE-CELL-LOCATION var))
	   (%p-store-data-type-and-pointer
	     (if (/= DTP-EXTERNAL-VALUE-CELL-POINTER (%p-data-type (locf (SECOND b))))
		 (locf (second b))
		 (%P-CONTENTS-AS-LOCATIVE (locf (second b))))
	     DTP-EXTERNAL-VALUE-CELL-POINTER (VALUE-CELL-LOCATION var)))
	 )))

(DEFMACRO ZL-WITH-PARALLEL-BASIC-FRAME ((varlist) &BODY body)
    `(PROG (symbol value)
	   (%PUSH 'stack-marker)
	   (DO ((nextbinding ,varlist (CDR nextbinding)))
	       ((ATOM nextbinding))
	     (SETQ symbol (IF (CONSP (CAR nextbinding)) (CAAR nextbinding) (CAR nextbinding)))
	     (IF (NOT (VARIABLE-P symbol))
		 (BINDING-ERROR (CAR nextbinding))
		 (%PUSH (IF (CONSP (CAR nextbinding)) (*EVAL (CADAR nextbinding)) nil))
		 (%PUSH (VALUE-CELL-LOCATION symbol))))
	BINDLOOP ;; 'DO' does not work here so must resort to PROG
	   (SETQ symbol (%POP))
	   (UNLESS (EQ symbol 'stack-marker)
	     (SETQ value (%POP))
	     (BIND symbol value)
	     (GO BINDLOOP))
	   (RETURN (PROGN . ,body))))

(DEFMACRO ZL-WITH-SERIAL-BASIC-FRAME ((varlist) &body body)
    `(DO ((nextbinding ,varlist (CDR nextbinding))
	  (symbol))
	 ((ATOM nextbinding)
	  (PROGN . ,body))
       (SETQ symbol (IF (CONSP (CAR nextbinding)) (CAAR nextbinding) (CAR nextbinding)))
       (IF (VARIABLE-P symbol)
	   (BIND (VALUE-CELL-LOCATION symbol) 
		 (IF (CONSP (CAR nextbinding)) (*EVAL (CADAR nextbinding)) nil))
	   (BINDING-ERROR (CAR nextbinding)))))


;;PHD 1/20/87, to get around the stack-list eq'ness problem, the catch tag is a locative on a local.
;;It is not going to get changed by anybody and is a unique ID of the call (which is what we were after).
;;4/11/88 CLM for PHD -  fix for spr 5065 (if pdl grown while evaluating a block, the catch is lost).
(DEFMACRO ENTER-BLOCK (name &body body)
    `(LET ((bindframe (%MAKE-STACK-LIST 3)))
       (SETF (CAR bindframe) 'block)
       (SETF (CADR bindframe) ,name)
       (SETF (CADDR bindframe) (%make-pointer dtp-u-entry (LOCF bindframe)))  ;; save stack address of bindframe
       (UNWIND-PROTECT
	   ;; set up catcher for tosses from GO,TAGBODY,RETURN,RETURN-FROM
	   (CATCH (%make-pointer dtp-u-entry (LOCF bindframe))
	     (WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* bindframe *INTERPRETER-ENVIRONMENT*)
	       (PROGN . ,body)))
	 (SETF (CADDR bindframe) nil))))