;;; -*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10 -*-
1;;; 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.*
;;;Record of changes:
;;; 04/24/89 jlm - moved APPLYHOOK and EVALHOOK vars to ZLC
;;; 03/03/89 clm - changed LOOKUP-SYMBOL-VALUE so that we do not default to the Zetalisp
;;; method of looking for a symbol's value if we are not in Common Lisp mode.
;;; Someone may have defined a new mode (as in SPR 9291).
(PROCLAIM '(INLINE ZETALISP-ON-P COMMON-LISP-ON-P))
;;;11/06/87 CLM - changed the default value of this variable to T.
(DEFVAR *INTERPRETER-MAXIMUM-ERROR-CHECKING* T
1 "Setting this to T causes the evaluator to undertake more extensive error checking.")*
(DEFVAR SLOTS-BOUND-INSTANCE nil
1"if this is not nil, then it represents an instance whose instance variables
were bound most recently by ZL-APPLY-LAMBDA"*)
(Defun BINDING-ERROR (sexp)
(FERROR nil 1"attempted to bind a non-symbol or a constant symbol: ~s"* sexp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; INTERPRETER-SET, ETC.
;;
(Defsubst INTERPRETER-SET (symbol value)
1"sets the value of SYMBOL to VALUE in either the current lexical environment, if
found there, or globally"*
(LET ((vcaddress (LOCF (SYMBOL-VALUE symbol)))) ; get value cell address
(DOLIST (frame *INTERPRETER-ENVIRONMENT* (SET symbol value))
(LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) vcaddress)))
(IF slot (RETURN (SETF (CAR slot) value)))))))
(Defsubst INTERPRETER-EXTERNAL-VALUE-CELL (symbol)
1"returns a locative to the place where the value of the symbol is stored either
in the current lexical environment, if found there, or in the global one."*
(LET ((vcaddress (LOCF (SYMBOL-VALUE symbol)))) ; get value cell address
(DOLIST (frame *INTERPRETER-ENVIRONMENT* (%EXTERNAL-VALUE-CELL symbol))
(LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) vcaddress)))
(when slot
(return
;;PHD 2/4/87 find out if it is a special variable reference.
(if (= (%P-DATA-TYPE slot) DTP-EXTERNAL-VALUE-CELL-POINTER)
(%EXTERNAL-VALUE-CELL symbol)
slot)))))))
(Defsubst INTERPRETER-FSYMEVAL (symbol)
1"Search the current lexical environment for a local macro or function
definition. If a local definition cannot be found, SYMBOL-FUNCTION is used
to locate a global definition of the same name."*
(LET ((faddress (LOCF (SYMBOL-FUNCTION symbol))))
(DOLIST (frame *INTERPRETER-FUNCTION-ENVIRONMENT* (SYMBOL-FUNCTION symbol))
(LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) faddress)))
(WHEN slot (RETURN (CAR slot)))))))
(Defun VARIABLE-BOUNDP ("E variable)
1"SYNTAX:(VARIABLE-BOUNDP variable)
Returns T if VARIABLE has a binding and NIL otherwise."*
(IF (ZETALISP-ON-P) (BOUNDP variable)
(LET ((vcaddress (LOCF (SYMBOL-VALUE variable)))) ; get value cell address
(DOLIST (frame *INTERPRETER-ENVIRONMENT* (BOUNDP variable))
(LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) vcaddress)))
(when slot
(return
;;PHD 2/4/87 find out if it is a special variable reference.
(if (= (%P-DATA-TYPE slot) DTP-EXTERNAL-VALUE-CELL-POINTER)
(boundp variable)
t))))))))
(Defun VARIABLE-LOCATION ("E variable)
1"Return a locative pointer to the place where the value of VARIABLE is stored."*
(IF (ZETALISP-ON-P)
(%EXTERNAL-VALUE-CELL variable)
(INTERPRETER-EXTERNAL-VALUE-CELL variable)))
(Defun VARIABLE-MAKUNBOUND ("E variable)
1"Make the VARIABLE unbound. References to it will get errors."*
(IF (ZETALISP-ON-P)
(LOCATION-MAKUNBOUND (%EXTERNAL-VALUE-CELL variable))
(LET ((vcaddress (LOCF (SYMBOL-VALUE variable)))) ; get value cell address
(if ;;PHD 2/4/87 find out if it is a special binding.
(DOLIST (frame *INTERPRETER-ENVIRONMENT* t)
(LET ((slot (GET-LOCATION-OR-NIL (LOCF frame) vcaddress)))
(when slot
(return
;;PHD 2/4/87 find out if it is a special variable reference.
(if (= (%P-DATA-TYPE slot) DTP-EXTERNAL-VALUE-CELL-POINTER)
t
nil)))))
(LOCATION-MAKUNBOUND (%EXTERNAL-VALUE-CELL variable))
(cerror "do nothing and return nil"
"VARIABLE-MAKUNBOUND is not allowed on local variable such as ~S" variable)))))
;;AB 7/29/87. Fix THE for type of (FUNCTION arg-types result-type). Also fix
;; doc string & ARGLIST. [SPR 5779]
(Defun THE ("E &REST x)
"Declares the value produced by evaluating FORM to be of specified TYPE.
FORM is evaluated and its values are returned.
In compiled code TYPE acts as a declaration and can authorize compiler optimizations.
In interpreted code an error will be signalled if the result of evaluating FORM is not
the specified TYPE."
(DECLARE (ARGLIST "E TYPE &EVAL FORM))
(LET ((type (TYPE-CANONICALIZE (CAR x))))
(COND ((AND (LISTP type) (EQ (CAR type) 'VALUES))
(LET ((values (MULTIPLE-VALUE-LIST (*EVAL (CADR x)))))
(DO ((val values (CDR val))
(typ (CDR type) (CDR typ))
(num 1 (1+ num)))
((OR (NULL val) (NULL typ))
(WHEN (OR val typ)
(CERROR "continue anyway."
"Got ~D value~:P when expecting ~D."
(LENGTH values) (1- (LENGTH type))))
(VALUES-LIST values))
(UNLESS (TYPEP (CAR val) (CAR typ))
(ERROR "~@(~:R~) value ~S should be a ~S."
num (CAR val) (CAR typ))))))
((AND (LISTP type) (EQ (CAR type) 'FUNCTION))
(PROG ((fn (*EVAL (CADR x))))
RETRY
(COND ((FUNCTIONP fn t)
(RETURN fn))
(T (CERROR
"Prompt for a new object."
"Object ~S is not a FUNCTION."
fn)
(TERPRI)
(PRINC "New object of proper type: ")
(SETQ fn (*EVAL (READ)))
(GO retry)))))
(t
(PROG ((obj (*EVAL (cadr x))))
RETRY
(COND ((TYPEP obj (CAR x))
(RETURN obj))
(T (CERROR
"Prompt for a new object."
"Object ~S is not of type ~S."
obj (CAR x))
(TERPRI)
(PRINC "New object of proper type: ")
(SETQ obj (*EVAL (READ)))
(GO retry)))))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; EVALHOOK & APPLYHOOK
;;
(DEFVAR ZLC:EVALHOOK :unbound) ; jlm 4/24/89
(DEFVAR *EVALHOOK* nil
"Value is function used on calls to EVAL, inside calls to EVALHOOK.")
(FORWARD-VALUE-CELL 'zlc:evalhook '*evalhook*) ; jlm 4/24/89
;; 4/11/89 DNG - Reversed the forwarding to indirect the old symbol to the new one.
(unless cold-booting ; temporary to undo old forwarding if this file is reloaded
(%P-STORE-TAG-AND-POINTER (VALUE-CELL-LOCATION '*EVALHOOK*) DTP-symbol 0)
(%P-STORE-TAG-AND-POINTER (VALUE-CELL-LOCATION '*APPLYHOOK*) DTP-symbol 0))
(DEFVAR *SKIP-EVALHOOK* nil
"used in conjunction with *EVALHOOK* to supress use of the hook function for one level of evaluation")
(DEFVAR ZLC:APPLYHOOK :unbound) ; jlm 4/24/89
(DEFVAR *APPLYHOOK* nil
"Value is function used on applications performed by EVAL, inside calls to EVALHOOK.
The function receives two arguments, like those which APPLY would receive.")
(FORWARD-VALUE-CELL 'zlc:applyhook '*applyhook*) ; jlm 4/24/89
(DEFVAR *SKIP-APPLYHOOK* nil
"used in conjunction with *APPLYHOOK* to supress use of the hook function for one level of evaluation")
;; 4/11/89 DNG - Added binding of *INTERPRETER-EXTRA-ENVIRONMENT*. Updated doc string.
(Defun EVALHOOK (form evalhookfn applyhookfn &optional env)
(declare (arglist form *evalhook* *applyhook* &optional environment))
"Evaluate FORM, using specified *EVALHOOK* and *APPLYHOOK* except at the top level.
ENVIRONMENT is the lexical environment to eval in. NIL means the global environment.
Or use the environment argument passed to an evalhook function."
(let ((*evalhook* evalhookfn) (*applyhook* applyhookfn)
(*skip-applyhook* nil)
(*skip-evalhook* (not (null evalhookfn))))
(if env
(let ((*interpreter-environment* (car env))
(*interpreter-function-environment* (cadr env))
(*interpreter-extra-environment* (cddr env)))
(*eval form))
(*eval form))))
;; 4/11/89 DNG - Added binding of *INTERPRETER-EXTRA-ENVIRONMENT*. Updated doc string.
(Defun applyhook (function args evalhookfn applyhookfn &optional env)
"Apply FUNCTION to ARGS, using specified *EVALHOOK* and *APPLYHOOK* except at the top level.
ENVIRONMENT is the lexical environment to eval in."
(let ((*evalhook* evalhookfn) (*skip-evalhook* nil)
(*applyhook* applyhookfn)
(*skip-applyhook* (not (null applyhookfn))))
(if env
(let ((*interpreter-environment* (car env))
(*interpreter-function-environment* (cadr env))
(*interpreter-extra-environment* (cddr env)))
(apply function args))
(apply function args))))
;; Note: The optional "environment" argument was a mistake. It is permitted
;; solely for compatibility with the release 3 edition of the Explorer Lisp
;; Reference Manual. In release 6, this was removed from the manual and a
;; compiler warning was added. In some future release, it could be eliminated
;; entirely. -- D.N.G. 4/11/89
(Defun CLI:EVAL (form &optional environment)
(declare (arglist form))
1"COMMON LISP SYNTAX:* 1(EVAL form)
Using COMMON LISP semantics, FORM is evaluated and its results returned."*
(DECLARE (ignore environment))
(WITH-COMMON-LISP-ON
(LET ((*INTERPRETER-ENVIRONMENT* '()) (*INTERPRETER-FUNCTION-ENVIRONMENT* '()))
(*EVAL form))))
(Defun GLOBAL:EVAL (form &OPTIONAL nohook)
1"ZETALISP SYNTAX:* 1(EVAL form)
Using ZETALISP semantics, FORM is evaluated and the results returned."*
(IF (AND *evalhook* (not nohook))
(WITH-ZETALISP-ON
(LET ((tem *evalhook*) *evalhook* *applyhook*)
(FUNCALL tem form NIL)))
(WITH-ZETALISP-ON
(LET (*INTERPRETER-FUNCTION-ENVIRONMENT* *INTERPRETER-ENVIRONMENT*)
(*EVAL form)))))
;;PHD 2/12/87 Use copy-list-into-heap for safe use of the environment by user hooks.
;;DNG 4/11/89 Added use of *INTERPRETER-EXTRA-ENVIRONMENT*.
(Defun EVAL1 (form &optional nohook) ;; old internal evaluator -- just a shell of its former self
(IF *evalhook*
(IF nohook
(LET ((*SKIP-EVALHOOK* t))
(*EVAL form))
(LET ((tem *evalhook*) *evalhook* *applyhook*
(*INTERPRETER-ENVIRONMENT* (copy-list-into-heap *INTERPRETER-ENVIRONMENT* ))
(*INTERPRETER-FUNCTION-ENVIRONMENT* (copy-list-into-heap *INTERPRETER-FUNCTION-ENVIRONMENT* )))
(with-interpreter-environment (env *INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*
*INTERPRETER-EXTRA-ENVIRONMENT*)
(FUNCALL tem form env))))
(*EVAL form)))
;;AB 07-17-87. Call EVAL1 instead of *EVAL because former takes a second arg. [SPR 6036, 5776]
(Defun INVALID-FUNCTION (form)
1"Report an invalid-function error in FORM and reevaluate with the function the user gives us."*
(EVAL1 (CONS (CERROR ':new-function nil 'sys:invalid-function
(IF (SYMBOLP (CAR form))
"The function ~S has a function definition which is invalid"
"The object ~S is not a valid function")
(CAR form))
(CDR form))
t))
1;;; NO APPLYHACK HOOKERY AS YET*
(Defmacro DETERMINE-IF-QUOTING-OR-EVALING-ARG (formal-args quotep)
;;; This guy examines one or more entries in a formal parameter list
;;; until it finds a formal parameter. State variables are set when
;;; certain lambda list keywords are seen.
`(DO (fvar)
((ENDP ,formal-args))
(SETQ fvar (POP ,formal-args))
(IF (LAMBDA-LIST-KEYWORD-P fvar)
(CASE fvar
(&AUX
(SETQ ,formal-args nil)
(RETURN))
("E
(SETQ ,quotep t))
(&EVAL
(SETQ ,quotep nil)))
(RETURN))
))
(Defsubst INVOKE-SPECIAL-FORM (fct formal-args unevaled-args)
;; Despite its title, this can be used to invoke functions as well
;; as special forms. However using this to invoke a function would
;; force us to page-in the debug-info-struct.
(LET ((number-of-args-pushed (LENGTH unevaled-args)))
(%ASSURE-PDL-ROOM number-of-args-pushed)
(DO ((rest-unevaled-args unevaled-args (CDR rest-unevaled-args))
arg
quotep)
((ENDP rest-unevaled-args)
(%CALL fct number-of-args-pushed))
(SETQ arg (CAR rest-unevaled-args))
(DETERMINE-IF-QUOTING-OR-EVALING-ARG formal-args quotep)
(%PUSH (IF quotep arg (*EVAL arg))))))
;; 4/11/89 DNG - Add use of *INTERPRETER-EXTRA-ENVIRONMENT* .
(Defsubst INVOKE-FUNCTION (fct-obj unevaled-args)
;; this guy evaluates and pushes each arg onto the stack
;; and then invokes the microcode function calling machinery. Error
;; checking for "too many" or "too few" args and even for "illegal
;; function object" are left to the microcode machinery.
(if (and *applyhook* (not (prog1 *skip-applyhook* (setq *skip-applyhook* nil))))
(do* ((rest-unevaled-args unevaled-args (cdr rest-unevaled-args))
(anchor nil)
(loc (locf anchor)))
((atom rest-unevaled-args)
(let ((hookfct *applyhook*)
(*applyhook* nil)
(*interpreter-environment* (copy-list-into-heap *interpreter-environment* ))
(*interpreter-function-environment* (copy-list-into-heap *interpreter-function-environment*)))
(with-interpreter-environment
(env *interpreter-environment* *interpreter-function-environment* *interpreter-extra-environment*)
(funcall hookfct fct-obj anchor env))))
(rplacd loc (setq loc (cons (*eval (car rest-unevaled-args)) nil))))
(LET ((number-of-args-pushed (LENGTH unevaled-args)))
(%ASSURE-PDL-ROOM number-of-args-pushed )
(DO ((rest-unevaled-args unevaled-args (CDR rest-unevaled-args)))
((NULL rest-unevaled-args)
(%CALL fct-obj number-of-args-pushed))
(%PUSH (*EVAL (CAR rest-unevaled-args)))))))
(Defmacro LOOKUP-SYMBOL-VALUE (symbol)
`(IF (ZETALISP-ON-P) ;; clm 03/03/89 changed from (COMMON-LISP-ON-P)
(SYMBOL-VALUE ,symbol)
(LET ((vcell (LOCF (SYMBOL-VALUE ,symbol))))
(DOLIST (frame *INTERPRETER-ENVIRONMENT* (SYMBOL-VALUE ,symbol))
(LET ((value (GET-LOCATION-OR-NIL (LOCF frame) vcell)))
(WHEN value (RETURN (CAR value))))))
))
;;;PHD 1/19/87 Returns second value: T when the symbol was found locally
(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))))))
(SYMBOL-FUNCTION ,symbol)))
;;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 4/11/89 Add use of *INTERPRETER-EXTRA-ENVIRONMENT* in the hook environment.
(Defun *EVAL (form)
1;;; Internal evaluator which evaluates