(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "30-Dec-93 14:27:43" |{DSK}export>lispcore>clos>2.0>CMLEVAL.;1| 102797 |changes| |to:| (OPTIMIZERS CL-EVAL-FN3-CALL) |previous| |date:| " 1-Apr-92 12:43:15" |{DSK}export>lispcore>sources>CMLEVAL.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CMLEVALCOMS) (RPAQQ CMLEVALCOMS ( (* |;;;| "Common Lisp interpreter") (COMS (* |;;| "These really don't belong here") (FUNCTIONS CL:EQUAL CL:EQUALP) (* |;;|  "For the byte compiler: Optimize by constant fold and coerce to EQ where possible") (PROP BYTEMACRO CL:EQUAL CL:EQUALP) (PROP DOPVAL CL:EQUAL)) (COMS (FUNCTIONS \\REMOVE-DECLS) (FUNCTIONS CL:SPECIAL-FORM-P)) (COMS (SPECIAL-FORMS INTERLISP) (PROP DMACRO INTERLISP COMMON-LISP) (FNS COMMON-LISP)) (COMS (ADDVARS (LAMBDASPLST CL:LAMBDA)) (FNS \\TRANSLATE-CL\:LAMBDA) (VARIABLES *CHECK-ARGUMENT-COUNTS* *SPECIAL-BINDING-MARK*)) (VARIABLES CL:LAMBDA-LIST-KEYWORDS CL:CALL-ARGUMENTS-LIMIT CL:LAMBDA-PARAMETERS-LIMIT) (STRUCTURES CLOSURE ENVIRONMENT) (FUNCTIONS \\MAKE-CHILD-ENVIRONMENT) (COMS (FNS CL:EVAL \\EVAL-INVOKE-LAMBDA \\INTERPRET-ARGUMENTS \\INTERPRETER-LAMBDA CHECK-BINDABLE CHECK-KEYWORDS) (FUNCTIONS ARG-REF) (PROP DMACRO .COMPILER-SPREAD-ARGUMENTS.)) (FNS DECLARED-SPECIAL) (COMS (* \;  "FUNCALL and APPLY, not quite same as Interlisp") (FNS CL:FUNCALL CL:APPLY) (PROP DMACRO CL:APPLY CL:FUNCALL)) (COMS (* \;  "COMPILER-LET needs to work differently compiled and interpreted") (FNS CL:COMPILER-LET COMP.COMPILER-LET) (PROP DMACRO CL:COMPILER-LET) (SPECIAL-FORMS CL:COMPILER-LET)) (COMS (* \;  "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.") (SPECIAL-FORMS CL:MACROLET CL:FLET CL:LABELS)) (SPECIAL-FORMS QUOTE) (COMS (SPECIAL-FORMS THE) (PROP DMACRO THE)) (COMS (PROP DMACRO CL:EVAL-WHEN) (FNS CL:EVAL-WHEN) (SPECIAL-FORMS CL:EVAL-WHEN)) (COMS (SPECIAL-FORMS DECLARE) (FUNCTIONS CL:LOCALLY)) (COMS (* \; "Interlisp version on LLINTERP") (SPECIAL-FORMS PROGN) (FNS \\EVAL-PROGN)) (COMS (* \;  "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex") (* \;  "The Interlisp function is on LLINTERP") (SPECIAL-FORMS PROG1) (FUNCTIONS PROG1)) (COMS (SPECIAL-FORMS LET* LET) (PROP MACRO LET LET*) (FNS \\LET*-RECURSION |\\LETtran|)) (COMS (SPECIAL-FORMS COND) (FUNCTIONS COND)) (COMS (FNS CL:IF) (SPECIAL-FORMS CL:IF) (PROP DMACRO CL:IF)) (COMS (* \;  "Interlisp NLAMBDA definitions on LLINTERP") (* \; "both special form and macro") (FUNCTIONS AND OR) (SPECIAL-FORMS AND OR)) (COMS (* \; "BLOCK and RETURN go together") (FNS CL:BLOCK) (PROP DMACRO CL:BLOCK) (SPECIAL-FORMS CL:BLOCK) (FUNCTIONS RETURN) (FNS CL:RETURN-FROM) (SPECIAL-FORMS CL:RETURN-FROM)) (COMS (* \;  "IL and CL versions of FUNCTION.") (FNS CL:FUNCTION) (PROP DMACRO CL:FUNCTION) (SPECIAL-FORMS CL:FUNCTION FUNCTION) (FUNCTIONS CL:FUNCTIONP CL:COMPILED-FUNCTION-P)) (SPECIAL-FORMS CL:MULTIPLE-VALUE-CALL CL:MULTIPLE-VALUE-PROG1) (FNS COMP.CL-EVAL) (FUNCTIONS CL:EVALHOOK CL:APPLYHOOK) (VARIABLES *EVALHOOK* *APPLYHOOK* CL::*SKIP-EVALHOOK* CL::*SKIP-APPLYHOOK*) (COMS (* \; "CONSTANTS mechanism") (FNS CL:CONSTANTP) (SETFS CL:CONSTANTP) (FUNCTIONS XCL::SET-CONSTANTP)) (COMS (* \;  "Interlisp SETQ for Common Lisp and vice versa") (SPECIAL-FORMS CL:SETQ SETQ) (PROP DMACRO CL:SETQ) (* |;;|  "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init") (FNS CL:SETQ) (FUNCTIONS SETQ) (FNS SET-SYMBOL) (FUNCTIONS CL:PSETQ) (FUNCTIONS SETQQ)) (COMS (SPECIAL-FORMS CL:CATCH CL:THROW CL:UNWIND-PROTECT) (FNS CL:THROW CL:CATCH CL:UNWIND-PROTECT)) (COMS (FUNCTIONS PROG PROG*) (SPECIAL-FORMS GO CL:TAGBODY) (FNS CL:TAGBODY)) (COMS (* \; "for macro caching") (FNS CACHEMACRO) (VARIABLES *MACROEXPAND-HOOK*) (VARS (*IN-COMPILER-LET* NIL))) (COMS (* |;;| "PROCLAIM and friends.") (* |;;| "Needs to come first because DEFVARs put it out. With package code in the init, also need this here rather than CMLEVAL") (FUNCTIONS CL:PROCLAIM) (* \; "used by the codewalker, too") (MACROS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-GLOBAL-P) (FUNCTIONS XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P) (FUNCTIONS XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P) (SETFS XCL::DECL-SPECIFIER-P XCL::GLOBALLY-NOTINLINE-P) (PROP PROPTYPE GLOBALLY-SPECIAL GLOBALVAR SI::DECLARATION-SPECIFIER SI::GLOBALLY-NOTINLINE SPECIAL-FORM)) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) CMLEVAL) (DECLARE\: EVAL@COMPILE DONTCOPY (OPTIMIZERS CL-EVAL-FN3-CALL)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA CL:TAGBODY CL:UNWIND-PROTECT CL:CATCH CL:SETQ CL:BLOCK CL:EVAL-WHEN CL:COMPILER-LET COMMON-LISP) (NLAML CL:THROW CL:FUNCTION CL:RETURN-FROM CL:IF) (LAMA CL:APPLY CL:FUNCALL))))) (* |;;;| "Common Lisp interpreter") (* |;;| "These really don't belong here") (CL:DEFUN CL:EQUAL (CL::X CL::Y) (CL:TYPECASE CL::X (CL:SYMBOL (EQ CL::X CL::Y)) (CL:NUMBER (EQL CL::X CL::Y)) (CONS (AND (CL:CONSP CL::Y) (CL:EQUAL (CAR CL::X) (CAR CL::Y)) (CL:EQUAL (CDR CL::X) (CDR CL::Y)))) (STRING (AND (CL:STRINGP CL::Y) (CL:STRING= CL::X CL::Y))) (CL:BIT-VECTOR (AND (CL:BIT-VECTOR-P CL::Y) (LET ((CL::SX (CL:LENGTH CL::X))) (AND (EQL CL::SX (CL:LENGTH CL::Y)) (CL:DOTIMES (CL::I CL::SX T) (CL:IF (NOT (EQ (BIT CL::X CL::I) (BIT CL::Y CL::I))) (RETURN NIL))))))) (PATHNAME (AND (CL:PATHNAMEP CL::Y) (%PATHNAME-EQUAL CL::X CL::Y))) (T (EQ CL::X CL::Y)))) (CL:DEFUN CL:EQUALP (CL::X CL::Y) (CL:TYPECASE CL::X (CL:SYMBOL (EQ CL::X CL::Y)) (CL:NUMBER (AND (CL:NUMBERP CL::Y) (= CL::X CL::Y))) (CONS (AND (CL:CONSP CL::Y) (CL:EQUALP (CAR CL::X) (CAR CL::Y)) (CL:EQUALP (CDR CL::X) (CDR CL::Y)))) (CL:CHARACTER (AND (CL:CHARACTERP CL::Y) (CL:CHAR-EQUAL CL::X CL::Y))) (STRING (AND (CL:STRINGP CL::Y) (STRING-EQUAL CL::X CL::Y))) (PATHNAME (AND (CL:PATHNAMEP CL::Y) (%PATHNAME-EQUAL CL::X CL::Y))) (CL:VECTOR (AND (CL:VECTORP CL::Y) (LET ((CL::SX (CL:LENGTH CL::X))) (AND (EQL CL::SX (CL:LENGTH CL::Y)) (CL:DOTIMES (CL::I CL::SX T) (CL:IF (NOT (CL:EQUALP (CL:AREF CL::X CL::I) (CL:AREF CL::Y CL::I))) (RETURN NIL))))))) (CL:ARRAY (AND (CL:ARRAYP CL::Y) (CL:EQUAL (CL:ARRAY-DIMENSIONS CL::X) (CL:ARRAY-DIMENSIONS CL::Y)) (LET ((CL::FX (%FLATTEN-ARRAY CL::X)) (CL::FY (%FLATTEN-ARRAY CL::Y))) (CL:DOTIMES (CL::I (CL:ARRAY-TOTAL-SIZE CL::X) T) (CL:IF (NOT (CL:EQUALP (CL:AREF CL::FX CL::I) (CL:AREF CL::FY CL::I))) (RETURN NIL)))))) (T (* |;;| "so that datatypes will be properly compared") (OR (EQ CL::X CL::Y) (LET ((CL::TYPENAME (TYPENAME CL::X))) (AND (EQ CL::TYPENAME (TYPENAME CL::Y)) (LET ((CL::DESCRIPTORS (GETDESCRIPTORS CL::TYPENAME))) (CL:IF CL::DESCRIPTORS (FOR CL::FIELD IN CL::DESCRIPTORS ALWAYS (CL:EQUALP (FETCHFIELD CL::FIELD CL::X) (FETCHFIELD CL::FIELD CL::Y))))))))))) (* |;;| "For the byte compiler: Optimize by constant fold and coerce to EQ where possible") (PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ) (PUTPROPS CL:EQUALP BYTEMACRO COMP.EQ) (PUTPROPS CL:EQUAL DOPVAL (2 CMLEQUAL)) (CL:DEFUN \\REMOVE-DECLS (CL::BODY CL::ENVIRONMENT) (* |;;;| "This is like parse-body, except that it returns the body and a list of specials declared in this frame. It side-effects the environment to mark the specials.") (PROG ((CL::SPECIALS NIL) CL::FORM) CL::NEXT-FORM (CL:IF (NULL CL::BODY) (GO CL::DONE)) (CL:SETQ CL::FORM (CAR CL::BODY)) CL::RETRY-FORM (COND ((OR (CL:ATOM CL::FORM) (NOT (CL:SYMBOLP (CAR CL::FORM)))) (GO CL::DONE)) ((EQ (CAR CL::FORM) 'DECLARE) (CL:MAPC #'(CL:LAMBDA (CL:DECLARATION) (CL:WHEN (CL:CONSP CL:DECLARATION) (CL:WHEN (OR (EQ (CAR CL:DECLARATION) 'CL:SPECIAL) (EQ (CAR CL:DECLARATION) 'SPECVARS)) (CL:IF (EQ (CDR CL:DECLARATION) T) (* |;;| "(specvars . t) refers to all variables inside this scope, not just those bound in this frame. So handling (specvars . t) by declaring the variables in this frame special would not be correct. Hence print a warning and continue.") (CL:WARN "(IL:SPECVARS . T) has no effect in the CL evaluator." ) (CL:MAPC #'(CL:LAMBDA (CL::NAME) (CL:PUSH CL::NAME CL::SPECIALS)) (CDR CL:DECLARATION)))))) (CDR CL::FORM)) (CL:POP CL::BODY) (GO CL::NEXT-FORM)) ((CL:SPECIAL-FORM-P (CAR CL::FORM)) (GO CL::DONE)) (T (LET ((CL::NEW-FORM (CL:MACROEXPAND-1 CL::FORM CL::ENVIRONMENT))) (COND ((AND (NOT (EQ CL::NEW-FORM CL::FORM)) (CL:CONSP CL::NEW-FORM)) (CL:SETQ CL::FORM CL::NEW-FORM) (GO CL::RETRY-FORM)) (T (GO CL::DONE)))))) CL::DONE (RETURN (CL:IF CL::SPECIALS (PROGN (FOR CL::VAR IN CL::SPECIALS DO (CL:SETF (ENVIRONMENT-VARS CL::ENVIRONMENT) (LIST* CL::VAR *SPECIAL-BINDING-MARK* (ENVIRONMENT-VARS CL::ENVIRONMENT)))) (CL:VALUES CL::BODY CL::SPECIALS)) CL::BODY)))) (CL:DEFUN CL:SPECIAL-FORM-P (CL::X) (GET CL::X 'SPECIAL-FORM)) (DEFINE-SPECIAL-FORM INTERLISP PROGN) (PUTPROPS INTERLISP DMACRO ((X . Y) (PROGN X . Y))) (PUTPROPS COMMON-LISP DMACRO ((X) X)) (DEFINEQ (common-lisp (nlambda common-lisp-forms (* \; "Edited 12-Feb-87 20:24 by Pavel") (\\eval-progn common-lisp-forms nil))) ) (ADDTOVAR LAMBDASPLST CL:LAMBDA) (DEFINEQ (\\translate-cl\:lambda (lambda (expr) (* \; "Edited 13-Feb-87 23:20 by Pavel") (let (vrbls keyvars optvars auxlist restform vartyp body keywords (cnt 1) (min 0) (max 0) decls (simplep t)) (|for| binding var |in| (car (cdr expr)) |do| (selectq binding ((&rest &body) (setq vartyp '&rest)) (&optional (setq vartyp binding)) (&aux (setq vartyp binding)) (&allow-other-keys (or (eq vartyp '&key) (error "&ALLOW-OTHER-KEYS not in &KEY"))) (&key (setq vartyp '&key)) (selectq vartyp (nil "required" (|push| vrbls binding) (|add| cnt 1) (|add| min 1) (|add| max 1) (and *check-argument-counts* (setq simplep nil))) (&rest (setq restform `((,binding (|for| i |from| ,cnt |to| |-args-| |collect| (arg |-args-| i))))) (setq max nil) (setq simplep nil)) (&aux (|push| auxlist binding)) (&key (let* (svar (init (cond ((listp binding) (prog1 (cadr binding) (setq svar (caddr binding)) (setq binding (car binding)))))) (key (cond ((listp binding) (prog1 (car binding) (setq binding (cadr binding)))) (t (make-keyword binding))))) (cond (svar (|push| keyvars (list svar t)))) (|push| keyvars (list binding `(|for| \\index |from| ,cnt |to| |-args-| |by| 2 |when| (eq (arg |-args-| \\index) ,key) |do| (return (arg |-args-| (add1 \\index)) ) |finally| (return ,(cond (svar `(progn (setq ,svar nil) ,init)) (t init))))))) (setq max nil) (setq simplep nil)) (&optional (or (listp binding) (setq binding (list binding))) (let ((svar (caddr binding))) (cl:when svar (|push| optvars svar) (setq simplep nil)) (cl:when (cadr binding) (setq simplep nil)) (|push| optvars `(,(car binding) (cond ((igreaterp ,cnt |-args-|) ,(cadr binding)) (t ,@(cond (svar `((setq ,svar t)))) (arg |-args-| ,cnt)))))) (and max (|add| max 1)) (|add| cnt 1)) (shouldnt)))) (cl:multiple-value-setq (body decls) (parse-body (cdr (cdr expr)) nil)) (cl:if simplep `(,'lambda (,@(reverse vrbls) ,@(mapcar (reverse optvars) (function car))) (declare (localvars . t)) ,@decls (,'let* (,@(reverse auxlist)) ,@decls ,@body)) `(lambda |-args-| (declare (localvars . t)) ,@(cond ((and *check-argument-counts* min (neq min 0)) `((cond ((ilessp ,'|-args-| ,min) (error "Too few args" ,'|-args-|)))))) ,@(cond ((and *check-argument-counts* max) `((cond ((igreaterp ,'|-args-| ,max) (error "Too many args" ,'|-args-|)))))) (,'let* (,@(|for| var |in| (reverse vrbls) |as| i |from| 1 |collect| (list var `(arg |-args-| ,i))) ,@(reverse optvars) ,@(reverse keyvars) ,@restform ,@(reverse auxlist)) ,@decls ,@body)))))) ) (CL:DEFPARAMETER *CHECK-ARGUMENT-COUNTS* NIL) (DEFGLOBALVAR *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible") (CL:DEFCONSTANT CL:LAMBDA-LIST-KEYWORDS '(&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT &CONTEXT)) (CL:DEFCONSTANT CL:CALL-ARGUMENTS-LIMIT 512) (CL:DEFCONSTANT CL:LAMBDA-PARAMETERS-LIMIT 512) (CL:DEFSTRUCT (CLOSURE (:PRINT-FUNCTION (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))))) (* |;;;| "An interpreted lexical closure. Contains the function and an environment object.") FUNCTION ENVIRONMENT) (CL:DEFSTRUCT (ENVIRONMENT (:CONSTRUCTOR \\MAKE-ENVIRONMENT NIL) (:COPIER \\COPY-ENVIRONMENT) (:PRINT-FUNCTION (LAMBDA (ENV STREAM DEPTH) (DECLARE (IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))))) (* |;;;| "An environment used by the Common Lisp interpreter. Every environment contains all of the information of its parents. That is, new child environments are made by copying the parent and then pushing new data onto one of the fields. This makes certain tests very fast.") (* |;;| "Lexically-bound or -declared variables. A property list mapping names into either *SPECIAL-BINDING-MARK* or their values.") VARS (* |;;| "Lexical functions and macros. A property list mapping names into either (:function . fn) or (:macro . expansion-fn).") FUNCTIONS (* |;;| "A property list mapping block names into unique blips. RETURN-FROMs can throw to the appropriate blip.") BLOCKS (* |;;| "A property list mapping TAGBODY bodies into unique blips. GOs throw the correct tail of the body to the blip.") TAGBODIES) (DEFMACRO \\MAKE-CHILD-ENVIRONMENT (PARENT &KEY ((:BLOCK (BLOCK-NAME BLOCK-BLIP)) NIL BLOCK-P) ((:TAGBODY (TAGBODY-TAIL TAGBODY-BLIP)) NIL TAGBODY-P)) `(LET* (($$PARENT ,PARENT) ($$NEW-ENV (CL:IF $$PARENT (\\COPY-ENVIRONMENT $$PARENT) (\\MAKE-ENVIRONMENT)))) ,@(AND BLOCK-P `((CL:SETF (ENVIRONMENT-BLOCKS $$NEW-ENV) (LIST* ,BLOCK-NAME ,BLOCK-BLIP (ENVIRONMENT-BLOCKS $$NEW-ENV))) )) ,@(AND TAGBODY-P `((CL:SETF (ENVIRONMENT-TAGBODIES $$NEW-ENV) (LIST* ,TAGBODY-TAIL ,TAGBODY-BLIP (ENVIRONMENT-TAGBODIES $$NEW-ENV))))) $$NEW-ENV)) (DEFINEQ (CL:EVAL (LAMBDA (CL::EXPRESSION CL::ENVIRONMENT) (* \; "Edited 1-Apr-92 12:39 by jds") (* |;;| "This is in Interlisp and not a DEFUN to help avoid bootstrap death, although bootstrap death is quite possible anyway if, for example, any of the macros here are in Common Lisp and the macro definitions are interpreted.") (DECLARE (LOCALVARS . T)) (COND ((AND *EVALHOOK* (NOT (PROG1 CL::*SKIP-EVALHOOK* (CL:SETQ CL::*SKIP-EVALHOOK* NIL) ))) (LET ((CL::HOOKFN *EVALHOOK*) (*EVALHOOK* NIL)) (CL:FUNCALL CL::HOOKFN CL::EXPRESSION CL::ENVIRONMENT))) (T (CL:TYPECASE CL::EXPRESSION (CL:SYMBOL (COND ((NULL CL::EXPRESSION) NIL) ((EQ CL::EXPRESSION T) T) (T (LET (CL::LOC CL::VAL) (CL:BLOCK CL::EVAL-VARIABLE (CL:WHEN CL::ENVIRONMENT (|for| CL::TAIL |on| (ENVIRONMENT-VARS CL::ENVIRONMENT) |by| (CDDR CL::TAIL) |when| (EQ CL::EXPRESSION (CAR CL::TAIL)) |do| (CL:SETQ CL::VAL (CADR CL::TAIL)) (COND ((EQ CL::VAL *SPECIAL-BINDING-MARK*) (* |;;|  "return from FOR loop, skipping to SPECIALS code below.") (RETURN NIL)) (T (CL:RETURN-FROM CL::EVAL-VARIABLE CL::VAL))))) (* |;;|  "following copied from \\EVALVAR in the Interlisp interpreter") (SETQ CL::LOC (\\STKSCAN CL::EXPRESSION)) (COND ((EQ (CL:SETQ CL::VAL (\\GETBASEPTR CL::LOC 0)) 'NOBIND) (* \;  "Value is NOBIND even if it was not found as the top-level value.") (CL:ERROR 'UNBOUND-VARIABLE :NAME CL::EXPRESSION)) (T CL::VAL))))))) (CONS (COND ((CL:CONSP (CAR CL::EXPRESSION)) (LET ((CL::ARGCOUNT 1)) (* |;;| "This is a very very awful hack for getting into internal lambda expressions .COMPILER-SPREAD-ARGUMENTS. is handled specially by the compiler--it iterates over a list pushing things") (* |;;| "secondly, the (OPCODES) directly calls EVAL-INVOKE-LAMBDA with more args than are given, blowing away the following APPLYFN. Larry thought this level of hackery was important for performance.") (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CL-EVAL-FN3-CALL (CAR CL::EXPRESSION) CL::ENVIRONMENT) ((CL:EVAL CL::ENVIRONMENT))))) (T (LET ((CL::FN-DEFN (AND CL::ENVIRONMENT (CL:GETF (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT) (CAR CL::EXPRESSION))))) (COND ((NULL CL::FN-DEFN) (* \;  "The normal case: the function is not lexically-defined.") (CASE (ARGTYPE (CAR CL::EXPRESSION)) ((0 2) (* |;;| "has a Interlisp/CommonLisp lambda-spread definition") (CL:IF (AND *APPLYHOOK* (NOT (PROG1 CL::*SKIP-APPLYHOOK* (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)))) (LET* ((CL::ARGS (CL:MAPCAR #'(CL:LAMBDA (CL::ARG) (CL:EVAL CL::ARG CL::ENVIRONMENT) ) (CDR CL::EXPRESSION))) (CL::HOOKFN *APPLYHOOK*) (*APPLYHOOK* NIL)) (CL:FUNCALL CL::HOOKFN (CAR CL::EXPRESSION) CL::ARGS CL::ENVIRONMENT)) (LET ((CL::ARGCOUNT 0)) (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CAR CL::EXPRESSION) ((CL:EVAL CL::ENVIRONMENT)))))) (T (* |;;|  "in Common Lisp, special form overrides nlambda definition") (* |;;| "note that the GET will error if not a symbol. ") (LET ((CL::TEMP (AND (CL:SYMBOLP (CAR CL::EXPRESSION)) (GET (CAR CL::EXPRESSION) 'SPECIAL-FORM)))) (COND (CL::TEMP (* \;  "CAR is the name of a special form.") (CL:FUNCALL CL::TEMP (CDR CL::EXPRESSION) CL::ENVIRONMENT)) ((CL:SETQ CL::TEMP (CL:MACRO-FUNCTION (CAR CL::EXPRESSION ))) (* \; "CAR is the name of a macro") (CL:EVAL (CL:FUNCALL CL::TEMP CL::EXPRESSION CL::ENVIRONMENT) CL::ENVIRONMENT)) (T (ERROR "Undefined car of form" (CAR CL::EXPRESSION))) ))))) ((EQ (CAR CL::FN-DEFN) :MACRO) (* \; "A use of a lexical macro.") (CL:EVAL (CL:FUNCALL (CDR CL::FN-DEFN) CL::EXPRESSION CL::ENVIRONMENT) CL::ENVIRONMENT)) (T (* \; "A call to a lexical function") (LET ((CL::ARGCOUNT 0)) (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CDR CL::FN-DEFN) ((CL:EVAL CL::ENVIRONMENT)))))))))) ((OR CL:NUMBER STRING CL:CHARACTER CL:BIT-VECTOR) (* |;;| "all of these are defined to be self-evaluating") CL::EXPRESSION) (T (CL:CERROR "Return the invalid expression as its own value" "~S is an invalid expression for EVAL." CL::EXPRESSION) CL::EXPRESSION)))))) (\\eval-invoke-lambda (lambda (n lam env) (declare (localvars . t)) (* \; "Edited 28-Apr-87 11:55 by Pavel") (let ((argblock (addstackbase (- (fetch (fx nextblock) of (\\myalink)) (+ (cl:decf n) n))))) (* |;;| "First sub-form is a list of (variable initialization) pairs. Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.") (cl:multiple-value-bind (body specials) (\\remove-decls (cddr lam) (cl:setq env (\\make-child-environment env))) (\\interpret-arguments "a LAMBDA as the CAR of a form" (case (car lam) ((lambda openlambda) '&interlisp) ((cl:lambda) '&required) (t (cl:error "(~S ...) is not legal as the CAR of a form." (car lam)))) (cadr lam) specials env body argblock n 0))))) (\\interpret-arguments (lambda (\\fn-name \\argtype \\arglist \\specials \\environment \\body \\argument-block \\length \\index) (* \; "Edited 7-Apr-88 16:16 by amd") (* |;;| "Written in a somewhat arcane style to avoid recursive calls whenever possible, & keep code inline. RECUR does a recursive call if under a PROGV, but otherwise does a GO. ") (cl:macrolet ((recur (tag) `(go ,tag)) (with-binding (var val &rest forms) `(progn (check-bindable ,var) (cl:if (or (fmemb ,var \\specials) (variable-globally-special-p ,var)) (cl:macrolet ((recur (tag) `(\\interpret-arguments \\fn-name ,(cl:if (eq tag 'in-keywords) '\\argtype `',tag) \\arglist \\specials \\environment \\body \\argument-block \\length \\index))) (cl:progv (list ,var) (list ,val) ,@forms)) (progn (cl:setf (environment-vars \\environment) (list* ,var ,val (environment-vars \\environment))) ,@forms))))) (prog (\\var \\val \\svar \\sp) (* |;;| "dispatch on input type. The in-keywords case is special, since it needs to pass down where the beginning of the keywords section is") (case \\argtype (&required (go &required)) (&optional (go &optional)) (&interlisp (go &interlisp)) (&rest (go &rest)) (&key (go &key)) (&aux (go &aux)) (&body (go &body)) (t (go in-keywords))) &required (return (cond ((null \\arglist) (cl:if (< \\index \\length) (cl:error 'too-many-arguments :callee \\fn-name :actual \\length :maximum \\index)) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&optional (recur &optional)) (&rest (recur &rest)) (&aux (recur &aux)) (&key (recur &key)) (t (cond ((>= \\index \\length) (cl:error 'too-few-arguments :callee \\fn-name :actual \\length :minimum (+ 1 \\index (for arg in \\arglist while (not (fmemb arg '(&optional &rest &aux &key))) sum 1))))) (setq \\val (arg-ref \\argument-block (prog1 \\index (cl:incf \\index)))) (with-binding \\var \\val (recur &required))))))) &optional (return (cond ((null \\arglist) (cl:if (< \\index \\length) (cl:error 'too-many-arguments :callee \\fn-name :actual \\length :maximum \\index)) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&rest (recur &rest)) (&aux (recur &aux)) (&key (recur &key)) (t (cl:if (>= \\index \\length) (cl:if (cl:consp \\var) (progn (setq \\val (cl:eval (cadr \\var) \\environment)) (setq \\svar (caddr \\var)) (setq \\var (car \\var)) (setq \\sp nil)) (setq \\val nil)) (progn (cond ((cl:consp \\var) (setq \\svar (caddr \\var)) (setq \\sp t) (setq \\var (car \\var)))) (setq \\val (arg-ref \\argument-block \\index)) (cl:incf \\index))) (with-binding \\var \\val (cl:if \\svar (with-binding \\svar \\sp (recur &optional)) (recur &optional)))))))) &interlisp (return (cond ((null \\arglist) (recur &body)) (t (setq \\var (|pop| \\arglist)) (cl:if (>= \\index \\length) (setq \\val nil) (progn (setq \\val (arg-ref \\argument-block \\index)) (cl:incf \\index))) (with-binding \\var \\val (recur &interlisp))))) &rest (setq \\var (|pop| \\arglist)) (setq \\val (|for| i |from| \\index |while| (< i \\length) |collect| (arg-ref \\argument-block i))) (return (with-binding \\var \\val (cl:if (null \\arglist) (recur &body) (case (|pop| \\arglist) (&aux (recur &aux)) (&key (recur &key)) (t (cl:error 'invalid-argument-list :callee \\fn-name)))))) &key (or (evenp (- \\length \\index)) (cl:error "Not an even number of arguments for &KEY")) (setq \\argtype \\arglist) (* \;  "Type is now the beginning of the keyword arguments") in-keywords (return (cond ((null \\arglist) (check-keywords \\argtype \\argument-block \\length \\index) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&aux (check-keywords \\argtype \\argument-block \\length \\index) (recur &aux)) (&allow-other-keys (cl:if (null \\arglist) (recur &body) (case (|pop| \\arglist) (&aux (recur &aux)) (t (cl:error 'invalid-argument-list :callee \\fn-name))))) (t (cond ((cl:consp \\var) (setq \\val (cadr \\var)) (setq \\svar (caddr \\var)) (setq \\var (car \\var))) (t (setq \\svar nil) (setq \\val nil))) (let ((key (cl:if (cl:consp \\var) (prog1 (car \\var) (setq \\var (cadr \\var))) (make-keyword \\var)))) (|for| i |from| \\index |while| (< i \\length) |by| 2 |do| (cl:if (eq (arg-ref \\argument-block i) key) (return (progn (setq \\val (arg-ref \\argument-block (+ i 1))) (setq \\sp t)))) |finally| (setq \\val (cl:eval \\val \\environment)) (setq \\sp nil))) (with-binding \\var \\val (cl:if \\svar (with-binding \\svar \\sp (recur in-keywords)) (recur in-keywords)))))))) &aux (return (cond ((null \\arglist) (recur &body)) (t (setq \\var (|pop| \\arglist)) (cl:if (cl:consp \\var) (progn (setq \\val (cl:eval (cadr \\var) \\environment)) (setq \\var (car \\var))) (setq \\val nil)) (with-binding \\var \\val (recur &aux))))) &body (return (cl:if (null (cdr \\body)) (cl:if (cl:consp (setq \\body (car \\body))) (case (car \\body) (cl:block (* |;;| "special case to handle BLOCK to avoid consing two environments just to enter a normal LAMBDA function") (let ((blip (cons nil nil))) (cl:setf (environment-blocks \\environment) (list* (cadr \\body) blip (environment-blocks \\environment))) (cl:catch blip (\\eval-progn (cddr \\body) \\environment)))) (t (cl:eval \\body \\environment))) (cl:eval \\body \\environment)) (progn (cl:eval (pop \\body) \\environment) (recur &body)))))))) (\\interpreter-lambda (lambda (n def env fn) (* \; "Edited 13-Feb-87 21:21 by Pavel") (declare (localvars . t)) (let ((argblock (addstackbase (|fetch| (bf ivar) |of| (|fetch| (fx blink) |of| (\\myalink)))))) (setq env (\\make-child-environment env)) (cl:multiple-value-bind (body specials) (\\remove-decls (cdr (cdr def)) env) (\\interpret-arguments fn '&required (car (cdr def)) specials env body argblock (- n 1) 0))))) (check-bindable (lambda (var) (* \; "Edited 13-Feb-87 22:06 by Pavel") (cl:unless (cl:symbolp var) (cl:error "Attempt to bind a non-symbol: ~S" var)) (cl:when (or (cl:constantp var) (fmemb var cl:lambda-list-keywords)) (cl:error (cl:if (cl:keywordp var) "Attempt to bind a keyword: ~S" "Attempt to bind a constant: ~S") var)) (cl:when (variable-global-p var) (cl:cerror "Go ahead and bind it anyway" "Attempt to bind a variable proclaimed global: ~S" var)) var)) (check-keywords (lambda (key-arguments argblock length n) (* \; "Edited 1-Dec-87 16:47 by amd") (* |;;| "check to see if any keywords in ARGBLOCK are not in the keys - not called if &ALLOW-OTHER-KEYS was set") (cl:block check-keys (let (badkeyword) (cl:do ((i n (+ i 2))) ((>= i length)) (let ((given-key (arg-ref argblock i))) (cl:if (eq given-key :allow-other-keys) (cl:if (arg-ref argblock (cl:1+ i)) (cl:return-from check-keys nil) nil) (cl:do ((keytail key-arguments (cdr keytail))) ((or (null keytail) (eq (car keytail) '&aux)) (* \; "got to end of keyword segment") (setq badkeyword given-key)) (let ((wanted-key (car keytail))) (if (cl:consp wanted-key) then (setq wanted-key (car wanted-key)) (cl:if (cl:consp wanted-key) (setq wanted-key (car wanted-key)) (setq wanted-key (make-keyword wanted-key))) else (setq wanted-key (make-keyword wanted-key)) ) (cl:if (eq wanted-key given-key) (return nil))))))) (cl:if badkeyword (cl:error "Keyword argument doesn't match expected list of keywords: ~A" badkeyword)))))) ) (DEFMACRO ARG-REF (BLOCK N) `(\\GETBASEPTR ,BLOCK (LLSH ,N 1))) (PUTPROPS .COMPILER-SPREAD-ARGUMENTS. DMACRO (APPLY COMP.SPREAD)) (DEFINEQ (declared-special (lambda (var decls) (* |lmm| "24-May-86 22:27") (and decls (or (and (listp (car decls)) (eq (caar decls) 'declare) (|for| dec |in| (cdar decls) |when| (and (eq (car dec) 'cl:special) (fmemb var (cdr dec))) |do| (return t))) (declared-special var (cdr decls)))))) ) (* \; "FUNCALL and APPLY, not quite same as Interlisp") (DEFINEQ (cl:funcall (cl:lambda (cl::fn &rest cl::args) (* \; "Edited 14-Feb-87 00:16 by Pavel") (cl:apply cl::fn cl::args))) (cl:apply (lambda cl::n (* \; "Edited 14-Feb-87 00:16 by Pavel") (cl:if (eq cl::n 0) (error "TOO FEW ARGUMENTS TO APPLY") (spreadapply (arg cl::n 1) (let ((cl::av (arg cl::n cl::n))) (for cl::i from (cl:1- cl::n) to 2 by -1 do (cl:push (arg cl::n cl::i) cl::av)) cl::av))))) ) (PUTPROPS CL:APPLY DMACRO (DEFMACRO (FN &REST ARGS) (CASE COMPILE.CONTEXT ((EFFECT RETURN) `(LET ((FN ,FN) (CNT ,(LENGTH (CDR ARGS)))) (.SPREAD. ((OPCODES) \,@ ARGS) CNT FN))) (T (* |;;|  "otherwise might not return multiple values") 'IGNOREMACRO)))) (PUTPROPS CL:FUNCALL DMACRO (DEFMACRO (FN &REST ARGS) (COND ((AND (NLISTP FN) (EVERY ARGS (FUNCTION NLISTP))) `((OPCODES APPLYFN) ,@ARGS ,(LENGTH ARGS) ,FN)) (T (LET ((TEM (GENSYM))) `((LAMBDA (,TEM) ((OPCODES APPLYFN) ,@ARGS ,(LENGTH ARGS) ,TEM)) ,FN)))))) (* \; "COMPILER-LET needs to work differently compiled and interpreted") (DEFINEQ (cl:compiler-let (nlambda $$compiler-let-tail (* \; "Edited 7-Apr-88 16:05 by amd") (cl:progv (|for| x |in| (car $$compiler-let-tail) |collect| (cond ((cl:consp x) (car x)) (t x))) (|for| x |in| (car $$compiler-let-tail) |collect| (cond ((cl:consp x) (\\eval (cadr x))))) (\\evprogn (cdr $$compiler-let-tail))))) (comp.compiler-let (lambda (\\a) (declare (localvars . t)) (* \; "Edited 7-Apr-88 16:38 by amd") (* entry point into bytecompiler) (* |lmm| "27-May-86 11:17") (cl:progv (|for| x |in| (car \\a) |collect| (|if| (cl:consp x) |then| (car x) |else| x)) (|for| x |in| (car \\a) |collect| (cond ((cl:consp x) (eval (cadr x))))) (comp.progn (cdr \\a))))) ) (PUTPROPS CL:COMPILER-LET DMACRO COMP.COMPILER-LET) (DEFINE-SPECIAL-FORM CL:COMPILER-LET (CL::ARGS &REST CL::BODY &ENVIRONMENT CL::ENV) (LET ((*IN-COMPILER-LET* T)) (DECLARE (CL:SPECIAL *IN-COMPILER-LET*)) (* \;  "the *IN-COMPILER-LET* is for macro-caching. It says: don't cache macros under compiler lets") (CL:PROGV (FOR CL::X IN CL::ARGS COLLECT (IF (CL:CONSP CL::X) THEN (CAR CL::X) ELSE CL::X)) (FOR CL::X IN CL::ARGS COLLECT (IF (CL:CONSP CL::X) THEN (CL:EVAL (CADR CL::X) CL::ENV) ELSE NIL)) (\\EVAL-PROGN CL::BODY CL::ENV)))) (* \; "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.") (DEFINE-SPECIAL-FORM CL:MACROLET (CL::MACRO-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) (FOR CL::MACRO-DEFN IN CL::MACRO-DEFNS DO (CL:SETQ CL::FUNCTIONS (LIST* (CAR CL::MACRO-DEFN) (CONS :MACRO `(CL:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) (CL:BLOCK ,(CAR CL::MACRO-DEFN) ,(PARSE-DEFMACRO (CADR CL::MACRO-DEFN) 'SI::$$MACRO-FORM (CDDR CL::MACRO-DEFN) (CAR CL::MACRO-DEFN) NIL :ENVIRONMENT 'SI::$$MACRO-ENVIRONMENT)))) CL::FUNCTIONS))) (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) CL::FUNCTIONS) (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) (DEFINE-SPECIAL-FORM CL:FLET (CL::FN-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) (FOR CL::FN-DEFN IN CL::FN-DEFNS DO (CL:SETQ CL::FUNCTIONS (LIST* (CL:FIRST CL::FN-DEFN) (CONS :FUNCTION (MAKE-CLOSURE :FUNCTION (CL:MULTIPLE-VALUE-BIND (CL::BODY CL::DECLS) (PARSE-BODY (CDDR CL::FN-DEFN) CL::ENV T) `(CL:LAMBDA ,(CL:SECOND CL::FN-DEFN) ,@CL::DECLS (CL:BLOCK ,(CL:FIRST CL::FN-DEFN) ,@CL::BODY))) :ENVIRONMENT CL::ENV)) CL::FUNCTIONS))) (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) CL::FUNCTIONS) (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) (DEFINE-SPECIAL-FORM CL:LABELS (CL::FN-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) (FOR CL::FN-DEFN IN CL::FN-DEFNS DO (CL:SETQ CL::FUNCTIONS (LIST* (CL:FIRST CL::FN-DEFN) (CONS :FUNCTION (* |;;| "Must share the environment object so that all of the new lexical function bindings appear in each new functions environment.") (MAKE-CLOSURE :FUNCTION (CL:MULTIPLE-VALUE-BIND (CL::BODY CL::DECLS) (PARSE-BODY (CDDR CL::FN-DEFN) CL::NEW-ENV T) `(CL:LAMBDA ,(CL:SECOND CL::FN-DEFN) ,@CL::DECLS (CL:BLOCK ,(CL:FIRST CL::FN-DEFN) ,@CL::BODY))) :ENVIRONMENT CL::NEW-ENV)) CL::FUNCTIONS))) (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) CL::FUNCTIONS) (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) (DEFINE-SPECIAL-FORM QUOTE CAR) (DEFINE-SPECIAL-FORM THE (CL::TYPE-SPEC CL::FORM &ENVIRONMENT CL::ENV) (CL:IF (AND (CL:CONSP CL::TYPE-SPEC) (EQ (CAR CL::TYPE-SPEC) 'CL:VALUES)) (LET ((CL:VALUES (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::FORM CL::ENV)))) (CL:IF (CL:NOTEVERY #'(CL:LAMBDA (CL::VALUE CL::SPEC) (TYPEP CL::VALUE CL::SPEC)) CL:VALUES (CDR CL::TYPE-SPEC)) (CHECK-TYPE-FAIL T CL::FORM CL:VALUES CL::TYPE-SPEC NIL) (CL:VALUES-LIST CL:VALUES))) (LET ((CL::VALUE (CL:EVAL CL::FORM CL::ENV))) (CL:IF (TYPEP CL::VALUE CL::TYPE-SPEC) CL::VALUE (CHECK-TYPE-FAIL T CL::FORM CL::VALUE CL::TYPE-SPEC NIL))))) (PUTPROPS THE DMACRO ((SPEC FORM) FORM)) (PUTPROPS CL:EVAL-WHEN DMACRO (DEFMACRO (OPTIONS &BODY BODY) (AND (OR (FMEMB 'COMPILE OPTIONS) (FMEMB 'CL:COMPILE OPTIONS) ) (MAPC BODY (FUNCTION CL:EVAL))) (AND (OR (FMEMB 'LOAD OPTIONS) (FMEMB 'CL:LOAD OPTIONS)) `(PROGN ,@BODY)))) (DEFINEQ (cl:eval-when (nlambda options.body (* |lmm| " 1-Jun-86 15:16") (and (or (fmemb 'cl:eval (car options.body)) (fmemb 'eval (car options.body))) (mapc (cdr options.body) (function \\eval))))) ) (DEFINE-SPECIAL-FORM CL:EVAL-WHEN (CL::TAGS &REST CL::BODY &ENVIRONMENT CL::ENV) (AND (OR (CL:MEMBER 'CL:EVAL CL::TAGS) (CL:MEMBER 'EVAL CL::TAGS)) (\\EVAL-PROGN CL::BODY CL::ENV))) (DEFINE-SPECIAL-FORM DECLARE FALSE) (DEFMACRO CL:LOCALLY (&BODY BODY) `(LET NIL ,@BODY)) (* \; "Interlisp version on LLINTERP") (DEFINE-SPECIAL-FORM PROGN \\EVAL-PROGN) (DEFINEQ (\\eval-progn (lambda (body environment) (* \; "Edited 12-Feb-87 20:25 by Pavel") (|if| (cdr body) |then| (cl:eval (car body) environment) (\\eval-progn (cdr body) environment) |else| (cl:eval (car body) environment)))) ) (* \; "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex") (* \; "The Interlisp function is on LLINTERP") (DEFINE-SPECIAL-FORM PROG1 (CL:FIRST &REST CL:REST &ENVIRONMENT CL::ENV) (LET ((CL::VAL (CL:EVAL CL:FIRST CL::ENV))) (CL:TAGBODY PROG1 (CL:IF CL:REST (PROGN (CL:EVAL (CAR CL:REST) CL::ENV) (CL:SETQ CL:REST (CDR CL:REST))) (CL:RETURN-FROM PROG1 CL::VAL)) (GO PROG1)))) (DEFMACRO PROG1 (CL:FIRST &REST CL:REST) `(LET ((SI::$PROG1-FIRST-EXPRESSION$ ,CL:FIRST)) (DECLARE (LOCALVARS SI::$PROG1-FIRST-EXPRESSION$)) ,@CL:REST SI::$PROG1-FIRST-EXPRESSION$)) (DEFINE-SPECIAL-FORM LET* (CL::VARS &REST CL::BODY &ENVIRONMENT CL::ENV) (CL:MULTIPLE-VALUE-BIND (CL::BODY CL::SPECIALS) (\\REMOVE-DECLS CL::BODY (CL:SETQ CL::ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV))) (\\LET*-RECURSION CL::VARS CL::SPECIALS CL::ENV CL::BODY))) (DEFINE-SPECIAL-FORM LET (CL::VARS &BODY CL::BODY &ENVIRONMENT CL::ENV &AUX CL::\\NEW-ENV) (* |;;| "Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.") (CL:MULTIPLE-VALUE-BIND (CL::\\BODY CL::SPECIALS) (\\REMOVE-DECLS CL::BODY (CL:SETQ CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV))) (* |;;| "Note that since remove decls side-effects the environment, variables which are declared special inside this scope will cause references inside the variable value forms to do special reference.") (LET ((CL::ENV-VARS (ENVIRONMENT-VARS CL::\\NEW-ENV)) CL::SPECVARS CL::SPECVALS CL::VALUE) (FOR CL::VAR IN CL::VARS DO (COND ((CL:CONSP CL::VAR) (* |;;| "NEW-ENV current has all of the new specials, but none of the new lexicals. This is the right environment to eval in.") (CL:SETQ CL::VALUE (CL:EVAL (CADR CL::VAR) CL::\\NEW-ENV)) (CL:SETQ CL::VAR (CAR CL::VAR))) (T (CL:SETQ CL::VALUE NIL))) (CHECK-BINDABLE CL::VAR) (IF (OR (FMEMB CL::VAR CL::SPECIALS) (VARIABLE-GLOBALLY-SPECIAL-P CL::VAR)) THEN (CL:PUSH CL::VAR CL::SPECVARS) (CL:PUSH CL::VALUE CL::SPECVALS) ELSE (CL:SETQ CL::ENV-VARS (LIST* CL::VAR CL::VALUE CL::ENV-VARS))) ) (CL:SETF (ENVIRONMENT-VARS CL::\\NEW-ENV) CL::ENV-VARS) (CL:IF CL::SPECVARS (CL:PROGV CL::SPECVARS CL::SPECVALS (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV)) (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV))))) (PUTPROPS LET MACRO (X (|\\LETtran| X))) (PUTPROPS LET* MACRO (X (|\\LETtran| X T))) (DEFINEQ (\\let*-recursion (lambda (vars $$let*-specials $$let*-env $$let*-body) (declare (localvars . t)) (* \; "Edited 7-Apr-88 16:09 by amd") (|bind| var value |for| $$let*-tail |on| vars |eachtime| (setq var (car $$let*-tail )) |do| (cond ((cl:consp var) (setq value (cl:eval (cadr var) $$let*-env)) (setq var (car var))) (t (setq value nil))) (check-bindable var) (cl:if (or (fmemb var $$let*-specials) (variable-globally-special-p var)) (return (cl:progv (list var) (list value) (\\let*-recursion (cdr $$let*-tail) $$let*-specials $$let*-env $$let*-body))) (cl:setf (environment-vars $$let*-env) (list* var value (environment-vars $$let*-env)))) |finally| (return (\\eval-progn $$let*-body $$let*-env))))) (|\\LETtran| (lambda (lettail sequentialp) (* \; "Edited 23-Dec-86 16:23 by lmm") (* |;;| "Interlisp version of LET/LET*/PROG*") (prog ((vars (mapcar (car lettail) (function (lambda (bindentry) (|if| (listp bindentry) |then| (car bindentry) |else| bindentry))))) (vals (mapcar (car lettail) (function (lambda (bindentry) (|if| (listp bindentry) |then| (cadr bindentry) |else| nil))))) (body (cdr lettail)) (decls nil)) (cl:multiple-value-setq (body decls) (parse-body body nil)) (return (|if| (not sequentialp) |then| `((,'lambda ,vars ,@decls ,@body) ,@vals) |elseif| (null (cdr vars)) |then| (selectq sequentialp (prog* `(prog ,@lettail)) `((,'lambda ,vars ,@decls ,@body) ,@vals)) |else| (* \;  "in the sequential case, all declarations must be included in each") (|if| (eq sequentialp 'prog*) |then| (setq body (list (list* 'prog nil body)))) (|for| var |in| (reverse (cdr vars)) |as| val |in| (reverse (cdr vals)) |do| (setq body `(((,'lambda (,var) ,@decls ,@body) ,val)))) `((,'lambda (,(car vars)) ,@decls ,@body) ,(car vals))))))) ) (DEFINE-SPECIAL-FORM COND (&REST CL::COND-CLAUSES &ENVIRONMENT CL::ENVIRONMENT) (PROG NIL CL::CONDLOOP (COND ((NULL CL::COND-CLAUSES) (RETURN NIL)) ((NULL (CDAR CL::COND-CLAUSES)) (RETURN (OR (CL:EVAL (CAAR CL::COND-CLAUSES) CL::ENVIRONMENT) (PROGN (CL:SETQ CL::COND-CLAUSES (CDR CL::COND-CLAUSES)) (GO CL::CONDLOOP))))) ((CL:EVAL (CAAR CL::COND-CLAUSES) CL::ENVIRONMENT) (RETURN (\\EVAL-PROGN (CDAR CL::COND-CLAUSES) CL::ENVIRONMENT))) (T (CL:SETQ CL::COND-CLAUSES (CDR CL::COND-CLAUSES)) (GO CL::CONDLOOP))))) (DEFMACRO COND (&REST CL::TAIL) (CL:IF CL::TAIL (CL:IF (NULL (CDAR CL::TAIL)) (CL:IF (CDR CL::TAIL) (LET ((VAR (CL:GENTEMP))) `(LET ((,VAR ,(CAAR CL::TAIL))) (CL:IF ,VAR ,VAR (COND ,@(CDR CL::TAIL))))) `(CL:VALUES ,(CAAR CL::TAIL))) `(CL:IF ,(CAAR CL::TAIL) ,(MKPROGN (CDAR CL::TAIL)) ,@(CL:IF (CDR CL::TAIL) (LIST (CL:IF (EQ (CAADR CL::TAIL) T) (CL:IF (NULL (CDADR CL::TAIL)) T (MKPROGN (CDADR CL::TAIL))) `(COND ,@(CDR CL::TAIL))))))))) (DEFINEQ (cl:if (nlambda (cl::test cl::then cl::else) (declare (localvars . t)) (* \; "Edited 12-Feb-87 20:27 by Pavel") (cl:if (\\eval cl::test) (\\eval cl::then) (\\eval cl::else)))) ) (DEFINE-SPECIAL-FORM CL:IF (CL::TEST CL::THEN &OPTIONAL CL::ELSE &ENVIRONMENT CL::ENVIRONMENT) (CL:IF (CL:EVAL CL::TEST CL::ENVIRONMENT) (CL:EVAL CL::THEN CL::ENVIRONMENT) (CL:EVAL CL::ELSE CL::ENVIRONMENT))) (PUTPROPS CL:IF DMACRO COMP.IF) (* \; "Interlisp NLAMBDA definitions on LLINTERP") (* \; "both special form and macro") (DEFMACRO AND (&REST CL::FORMS) (COND ((CDR CL::FORMS) `(CL:IF ,(CAR CL::FORMS) (AND ,@(CDR CL::FORMS)))) (CL::FORMS (CAR CL::FORMS)) (T T))) (DEFMACRO OR (&REST CL::FORMS) (CL:IF (NULL (CDR CL::FORMS)) (CAR CL::FORMS) `(LET ((SI::*OR-GENTEMP* ,(CAR CL::FORMS))) (DECLARE (LOCALVARS SI::*OR-GENTEMP*)) (CL:IF SI::*OR-GENTEMP* SI::*OR-GENTEMP* (OR ,@(CDR CL::FORMS)))))) (DEFINE-SPECIAL-FORM AND (&REST CL::AND-CLAUSES &ENVIRONMENT CL::ENV) (CL:LOOP (COND ((NULL CL::AND-CLAUSES) (RETURN T)) ((NULL (CDR CL::AND-CLAUSES)) (RETURN (CL:EVAL (CAR CL::AND-CLAUSES) CL::ENV))) (T (CL:IF (CL:EVAL (CAR CL::AND-CLAUSES) CL::ENV) (CL:POP CL::AND-CLAUSES) (RETURN NIL)))))) (DEFINE-SPECIAL-FORM OR (&REST CL::TAIL &ENVIRONMENT CL::ENV) (BIND CL::VAL FOR OLD CL::TAIL ON CL::TAIL (COND ((NULL (CDR CL::TAIL)) (RETURN (CL:EVAL (CAR CL::TAIL) CL::ENV))) ((CL:SETQ CL::VAL (CL:EVAL (CAR CL::TAIL) CL::ENV)) (RETURN CL::VAL))))) (* \; "BLOCK and RETURN go together") (DEFINEQ (cl:block (nlambda cl::tail (* \; "Edited 12-Feb-87 20:31 by Pavel") (\\evprogn (cdr cl::tail)))) ) (PUTPROPS CL:BLOCK DMACRO COMP.BLOCK) (DEFINE-SPECIAL-FORM CL:BLOCK (CL::NAME &REST CL::\\BODY &ENVIRONMENT CL::ENVIRONMENT) (* |;;| "Syntax is (BLOCK name . body). The body is evaluated as a PROGN, but it is possible to exit the block using (RETURN-FROM name value). The RETURN-FROM must be lexically contained within the block.") (LET* ((CL::BLIP (CONS NIL NIL)) (CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENVIRONMENT :BLOCK (CL::NAME CL::BLIP)))) (CL:CATCH CL::BLIP (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV)))) (DEFMACRO RETURN (CL::VALUE) `(CL:RETURN-FROM NIL ,CL::VALUE)) (DEFINEQ (cl:return-from (nlambda (cl::retfrom-tag cl::retfrom-value) (declare (localvars . t)) (* \; "Edited 12-Feb-87 20:35 by Pavel") (let ((cl::retvalues (cl:multiple-value-list (\\eval cl::retfrom-value)))) (let ((cl::frame (stknth 1))) (while cl::frame do (cl:if (or (and (null cl::retfrom-tag) (eq (stkname cl::frame) '\\prog0)) (and (eq (stkname cl::frame) 'cl:block) (eq (car (stkarg 1 cl::frame)) cl::retfrom-tag))) (retvalues cl::frame cl::retvalues t) (cl:setq cl::frame (stknth 1 cl::frame cl::frame ))) finally (cl:error 'illegal-return :tag cl::retfrom-tag)))))) ) (DEFINE-SPECIAL-FORM CL:RETURN-FROM (CL::BLOCK-NAME CL::EXPR &ENVIRONMENT CL::ENV) (LET ((CL::BLIP (AND CL::ENV (CL:GETF (ENVIRONMENT-BLOCKS CL::ENV) CL::BLOCK-NAME)))) (CL:IF (AND CL::BLOCK-NAME (NULL CL::BLIP)) (CL:ERROR 'ILLEGAL-RETURN :TAG CL::BLOCK-NAME) (LET ((CL::\\BLK CL::BLOCK-NAME) (CL::VALS (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::EXPR CL::ENV)))) (COND (CL::BLIP (* \;  "This is a CL RETURN-FROM, so do the throw.") (HANDLER-BIND ((ILLEGAL-THROW #'(CL:LAMBDA (CL::C) (DECLARE (IGNORE CL::C)) (CL:ERROR 'ILLEGAL-RETURN :TAG CL::\\BLK)))) (CL:THROW CL::BLIP (CL:VALUES-LIST CL::VALS)))) (T (* \;  "This is an IL RETURN, so return from the closest enclosing \\PROG0.") (RETVALUES (STKPOS '\\PROG0) CL::VALS T))))))) (* \; "IL and CL versions of FUNCTION.") (DEFINEQ (cl:function (nlambda (cl::fn) (* \; "Edited 30-Jan-87 19:07 by Pavel") (* |;;;| "Fake CL:FUNCTION for Interlisp --- no lexical closures") (cl:if (cl:symbolp cl::fn) (cl:symbol-function cl::fn) cl::fn))) ) (PUTPROPS CL:FUNCTION DMACRO (DEFMACRO (X) (COND ((CL:SYMBOLP X) `(CL:SYMBOL-FUNCTION ',X)) (T `(FUNCTION ,X))))) (DEFINE-SPECIAL-FORM CL:FUNCTION (CL::FN &ENVIRONMENT CL::ENVIRONMENT) (COND ((CL:SYMBOLP CL::FN) (LET (CL::FN-DEFN) (COND ((OR (NULL CL::ENVIRONMENT) (NULL (CL:SETQ CL::FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT ) CL::FN)))) (CL:SYMBOL-FUNCTION CL::FN)) ((EQ (CAR CL::FN-DEFN) :FUNCTION) (CDR CL::FN-DEFN)) (T (CL:ERROR "The lexical macro ~S is not a legal argument to ~S." CL::FN 'CL:FUNCTION))))) ((OR (NULL CL::ENVIRONMENT) (AND (FOR CL::VALUE IN (CDR (ENVIRONMENT-VARS CL::ENVIRONMENT)) BY CDDR ALWAYS (EQ CL::VALUE *SPECIAL-BINDING-MARK*)) (NULL (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT)) (NULL (ENVIRONMENT-BLOCKS CL::ENVIRONMENT)) (NULL (ENVIRONMENT-TAGBODIES CL::ENVIRONMENT)))) (* |;;| "Environment is empty: don't have to make a closure.") CL::FN) (T (MAKE-CLOSURE :FUNCTION (COND ((EQ (CAR CL::FN) 'LAMBDA) `(CL:LAMBDA (&OPTIONAL ,@(CADR CL::FN) &REST IGNORE) ,@(CDDR CL::FN))) (T CL::FN)) :ENVIRONMENT (\\COPY-ENVIRONMENT CL::ENVIRONMENT) (* \;  "environment is copied so that forms that side-effect it (such as LET*) will work correctly.") )))) (DEFINE-SPECIAL-FORM FUNCTION (FN &OPTIONAL FUNARGP &ENVIRONMENT ENVIRONMENT) (* |;;| "Interlisp FUNCTION in Common Lisp interpreter:") (* |;;| "like CL:FUNCTION except that (FUNCTION FOO) just returns FOO and not its definition.") (COND (FUNARGP (CL:FUNCALL #'FUNCTION FN FUNARGP)) ((CL:SYMBOLP FN) (LET (FN-DEFN) (COND ((OR (NULL ENVIRONMENT) (NULL (SETQ FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENVIRONMENT) FN)))) FN) ((EQ (CAR FN-DEFN) :FUNCTION) (CDR FN-DEFN)) (T (CL:ERROR "The lexical macro ~S is not a legal argument to ~S." FN 'FUNCTION))))) ((OR (NULL ENVIRONMENT) (AND (FOR VALUE IN (CDR (ENVIRONMENT-VARS ENVIRONMENT)) BY CDDR ALWAYS (EQ VALUE *SPECIAL-BINDING-MARK*)) (NULL (ENVIRONMENT-FUNCTIONS ENVIRONMENT)) (NULL (ENVIRONMENT-BLOCKS ENVIRONMENT)) (NULL (ENVIRONMENT-TAGBODIES ENVIRONMENT)))) FN) (T (MAKE-CLOSURE :FUNCTION (COND ((EQ (CAR FN) 'LAMBDA) `(CL:LAMBDA (&OPTIONAL ,@(CADR FN) &REST IGNORE) ,@(CDDR FN))) (T FN)) :ENVIRONMENT ENVIRONMENT)))) (CL:DEFUN CL:FUNCTIONP (CL::FN) (AND (OR (CL:SYMBOLP CL::FN) (CL:COMPILED-FUNCTION-P CL::FN) (AND (CL:CONSP CL::FN) (EQ (CAR CL::FN) 'CL:LAMBDA)) (CLOSURE-P CL::FN)) T)) (CL:DEFUN CL:COMPILED-FUNCTION-P (CL::FN) (OR (TYPEP CL::FN 'COMPILED-CLOSURE) (AND (ARRAYP CL::FN) (EQ (|fetch| (ARRAYP TYP) |of| CL::FN) \\ST.CODE)))) (DEFINE-SPECIAL-FORM CL:MULTIPLE-VALUE-CALL (CL::FN &REST CL::ARGS &ENVIRONMENT CL::ENV) (* |;;|  "for interpreted calls only. The macro inserts a \\MVLIST call after the computation of TAIL") (CL:APPLY (CL:EVAL CL::FN CL::ENV) (FOR CL::X IN CL::ARGS JOIN (\\MVLIST (CL:EVAL CL::X CL::ENV))))) (DEFINE-SPECIAL-FORM CL:MULTIPLE-VALUE-PROG1 (CL::FORM &REST CL::OTHER-FORMS &ENVIRONMENT CL::ENV ) (CL:VALUES-LIST (PROG1 (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::FORM CL::ENV)) (FOR CL::X IN CL::OTHER-FORMS DO (CL:EVAL CL::X CL::ENV))))) (DEFINEQ (comp.cl-eval (lambda (exp) (* |lmm| " 5-Jun-86 00:44") (comp.spread `(cdr ,@exp) '*eval-argument-count* `(car ,@exp) '((cl:eval environment))))) ) (CL:DEFUN CL:EVALHOOK (CL::FORM CL::EVALHOOKFN CL::APPLYHOOKFN &OPTIONAL CL::ENV) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form." (LET ((*EVALHOOK* CL::EVALHOOKFN) (CL::*SKIP-EVALHOOK* T) (*APPLYHOOK* CL::APPLYHOOKFN) (CL::*SKIP-APPLYHOOK* NIL)) (CL:EVAL CL::FORM CL::ENV))) (CL:DEFUN CL:APPLYHOOK (CL:FUNCTION CL::ARGS CL::EVALHOOKFN CL::APPLYHOOKFN &OPTIONAL CL::ENV ) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form." (DECLARE (IGNORE CL::ENV)) (* |;;| "the env argument is not used as agreed on the Common Lisp mailing list. (Arguments have already been evaluated.)") (LET ((*EVALHOOK* CL::EVALHOOKFN) (CL::*SKIP-EVALHOOK* T) (*APPLYHOOK* CL::APPLYHOOKFN) (CL::*SKIP-APPLYHOOK* NIL)) (CL:APPLY CL:FUNCTION CL::ARGS))) (CL:DEFVAR *EVALHOOK* NIL) (CL:DEFVAR *APPLYHOOK* NIL) (CL:DEFVAR CL::*SKIP-EVALHOOK* NIL "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:DEFVAR CL::*SKIP-APPLYHOOK* NIL "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (* \; "CONSTANTS mechanism") (DEFINEQ (cl:constantp (lambda (object environment) (* |vanMelle| "19-Nov-86 21:43") (cl:typecase object (cl:number t) (cl:character t) (string t) (cl:bit-vector t) (cl:symbol (or (eq object nil) (eq object t) (cl:keywordp object) (and compvarmacrohash (setq object (gethash object compvarmacrohash)) (cl:constantp object)))) (cons (case (car object) ((constant quote) t) (cl:otherwise (cond ((fmemb (car object) constantfoldfns) (every (cdr object) (function cl:constantp))) (t (cl:multiple-value-bind (new-form expanded) (cl:macroexpand object environment) (and expanded (cl:constantp new-form))))))))))) ) (CL:DEFSETF CL:CONSTANTP XCL::SET-CONSTANTP) (CL:DEFUN XCL::SET-CONSTANTP (CL:SYMBOL XCL::FLAG) (CL:IF (NOT (NULL XCL::FLAG)) (CL:SETF (GETHASH CL:SYMBOL COMPVARMACROHASH) `(CONSTANT ,CL:SYMBOL)) (CL:WHEN (TYPEP COMPVARMACROHASH 'CL:HASH-TABLE) (REMHASH CL:SYMBOL COMPVARMACROHASH)))) (* \; "Interlisp SETQ for Common Lisp and vice versa") (DEFINE-SPECIAL-FORM CL:SETQ (&REST CL::TAIL &ENVIRONMENT CL::ENV) (LET (CL::VALUE) (WHILE CL::TAIL DO (CL:SETQ CL::VALUE (SET-SYMBOL (CL:POP CL::TAIL) (CL:EVAL (CL:POP CL::TAIL) CL::ENV) CL::ENV))) CL::VALUE)) (DEFINE-SPECIAL-FORM SETQ (VAR VALUE &ENVIRONMENT ENV) (SET-SYMBOL VAR (CL:EVAL VALUE ENV) ENV)) (PUTPROPS CL:SETQ DMACRO (DEFMACRO (X Y &REST CL:REST) `(PROGN (SETQ ,X ,Y) ,@(AND CL:REST `((CL:SETQ ,@CL:REST)))))) (* |;;| "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init") (DEFINEQ (cl:setq (nlambda cl::tail (* \; "Edited 15-Nov-87 17:34 by jop") (let ((cl::value nil)) (cl:loop (cl:if (null cl::tail) (return cl::value)) (cl:setq cl::value (set (cl:pop cl::tail) (cl:if (not (boundp *evalhook*)) (progn (* |;;| "CMLEVAL Init-forms not yet run") (eval (cl:pop cl::tail))) (cl:eval (cl:pop cl::tail))))))))) ) (DEFMACRO SETQ (VAR &REST VALUE-FORMS) (COND ((NULL VALUE-FORMS) `(CL:SETQ ,VAR NIL)) ((NULL (CDR VALUE-FORMS)) `(CL:SETQ ,VAR ,(CAR VALUE-FORMS))) (T `(CL:SETQ ,VAR (PROG1 ,@VALUE-FORMS))))) (DEFINEQ (set-symbol (lambda (cl:symbol value environment) (* \; "Edited 7-Jan-87 15:37 by gbn") (cl:block set-symbol (|if| environment |then| (setq environment (environment-vars environment)) (while environment do (if (eq cl:symbol (car environment)) then (* |;;| "found a binding for this symbol") (if (eq (car (setq environment (cdr environment))) *special-binding-mark*) then (* |;;| "it is a special binding, or a mark that we are using the special value") (return nil) (* \; "return from WHILE") ) (rplaca environment value) (* |;;| "smash new value in") (cl:return-from set-symbol value) else (setq environment (cddr environment))))) (* |;;| "no environment, or not found") (setq environment (\\stkscan cl:symbol)) (cond ((eq (\\hiloc environment) \\stackhi) (\\putbaseptr environment 0 value)) (t (\\rplptr environment 0 value))) value))) ) (DEFMACRO CL:PSETQ (&REST TAIL) (AND TAIL `(PROGN (SETQ ,(|pop| TAIL) ,(CL:IF (CDR TAIL) `(PROG1 ,(POP TAIL) (CL:PSETQ ,@TAIL)) (CAR TAIL))) NIL))) (DEFMACRO SETQQ (SYMBOL VALUE) (* \;  "so common lisp interpreter will know about it") `(SETQ ,SYMBOL ',VALUE)) (DEFINE-SPECIAL-FORM CL:CATCH (CL::CATCH-TAG &REST CL::\\CATCH-FORMS &ENVIRONMENT CL::\\CATCH-ENV ) (CL:CATCH (CL:EVAL CL::CATCH-TAG CL::\\CATCH-ENV) (\\EVAL-PROGN CL::\\CATCH-FORMS CL::\\CATCH-ENV))) (DEFINE-SPECIAL-FORM CL:THROW (CL::TAG CL::VALUE &ENVIRONMENT CL::ENV) (CL:THROW (CL:EVAL CL::TAG CL::ENV) (CL:EVAL CL::VALUE CL::ENV))) (DEFINE-SPECIAL-FORM CL:UNWIND-PROTECT (CL::\\FORM &REST CL::\\CLEANUPS &ENVIRONMENT CL::\\ENV) (CL:UNWIND-PROTECT (CL:EVAL CL::\\FORM CL::\\ENV) (\\EVAL-PROGN CL::\\CLEANUPS CL::\\ENV))) (DEFINEQ (cl:throw (nlambda (throw-tag throw-value) (declare (localvars . t)) (* |lmm| "30-May-86 00:09") (cl:throw (\\eval throw-tag) (\\eval throw-value)))) (cl:catch (nlambda \\catch-forms (* \; "Edited 7-Apr-88 16:53 by amd") (cl:catch (\\eval (car \\catch-forms)) (\\evprogn (cdr \\catch-forms))))) (cl:unwind-protect (nlambda \\unwind-forms (* \; "Edited 7-Apr-88 16:54 by amd") (cl:unwind-protect (\\eval (car \\unwind-forms)) (\\evprogn (cdr \\unwind-forms))))) ) (DEFMACRO PROG (VARS &BODY (BODY DECLS)) `(CL:BLOCK NIL (LET ,VARS ,@DECLS (CL:TAGBODY ,@BODY)))) (DEFMACRO PROG* (VARS &BODY (BODY DECLS)) `(CL:BLOCK NIL (LET* ,VARS ,@DECLS (CL:TAGBODY ,@BODY)))) (DEFINE-SPECIAL-FORM GO (CL::\\TAG &ENVIRONMENT CL::ENV) (BIND CL::TAIL FOR CL::TAGBODIES ON (AND CL::ENV (ENVIRONMENT-TAGBODIES CL::ENV)) BY CDDR WHEN (CL:SETQ CL::TAIL (CL:MEMBER CL::\\TAG (CAR CL::TAGBODIES))) (* |;;| "MUST use EQL, as tags may be integers.") DO (HANDLER-BIND ((ILLEGAL-THROW #'(CL:LAMBDA (CL::C) (CL:ERROR 'ILLEGAL-GO :TAG CL::\\TAG)))) (CL:THROW (CADR CL::TAGBODIES) CL::TAIL)) FINALLY (CL:ERROR 'ILLEGAL-GO :TAG CL::\\TAG))) (DEFINE-SPECIAL-FORM CL:TAGBODY (&REST CL::\\TAGBODY-TAIL &ENVIRONMENT CL::ENV) (LET* ((CL::BLIP (CONS NIL NIL)) (CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV :TAGBODY (CL::\\TAGBODY-TAIL CL::BLIP) ))) (WHILE (CL:SETQ CL::\\TAGBODY-TAIL (CL:CATCH CL::BLIP (FOR CL::X IN CL::\\TAGBODY-TAIL UNLESS (CL:SYMBOLP CL::X) DO (CL:EVAL CL::X CL::\\NEW-ENV))) )))) (DEFINEQ (cl:tagbody (nlambda tail (* |lmm| "23-May-86 16:05") (* |like| prog |with| |no|  |variables|) (let ((tl (cons nil tail))) (\\prog0 tl tl)))) ) (* \; "for macro caching") (DEFINEQ (cachemacro (lambda (fn body env) (* \; "Edited 25-Sep-87 18:32 by jop") (* |;;;| "We want to cache the expansion unless") (* |;;| "1) the env is not an interpreted env (including NIL), ") (* |;;| "2) there are lexical macros in force, OR") (* |;;| "3) There is a compiler-let in force.") (cl:if (or (not (typep env 'environment)) (and env (for fn in (cdr (environment-functions env)) by cddr thereis (eq (car fn) :macro))) *in-compiler-let*) (cl:funcall fn body env) (or (gethash body clisparray) (puthash body (cl:funcall fn body env) clisparray))))) ) (CL:DEFPARAMETER *MACROEXPAND-HOOK* 'CACHEMACRO) (RPAQQ *IN-COMPILER-LET* NIL) (* |;;| "PROCLAIM and friends.") (* |;;| "Needs to come first because DEFVARs put it out. With package code in the init, also need this here rather than CMLEVAL" ) (CL:DEFUN CL:PROCLAIM (CL::PROCLAMATION) (* |;;| "PROCLAIM is a top-level form used to pass assorted information to the compiler. This interpreter ignores proclamations except for those declaring variables to be SPECIAL.") (CL:WHEN (CL:CONSP CL::PROCLAMATION) (CASE (CAR CL::PROCLAMATION) (CL:SPECIAL (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF ( VARIABLE-GLOBALLY-SPECIAL-P CL::X) T) (CL:SETF (VARIABLE-GLOBAL-P CL::X) NIL) (CL:SETF (CL:CONSTANTP CL::X) NIL))) (GLOBAL (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (VARIABLE-GLOBAL-P CL::X) T) (CL:SETF ( VARIABLE-GLOBALLY-SPECIAL-P CL::X) NIL) (CL:SETF (CL:CONSTANTP CL::X) NIL))) (SI::CONSTANT (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (CL:CONSTANTP CL::X) T) (CL:SETF (VARIABLE-GLOBAL-P CL::X) NIL) (CL:SETF (VARIABLE-GLOBALLY-SPECIAL-P CL::X) NIL))) (CL:DECLARATION (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (XCL::DECL-SPECIFIER-P CL::X) T))) (CL:NOTINLINE (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (XCL::GLOBALLY-NOTINLINE-P CL::X) T))) (CL:INLINE (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (  XCL::GLOBALLY-NOTINLINE-P CL::X) NIL)))))) (* \; "used by the codewalker, too") (DECLARE\: EVAL@COMPILE (PUTPROPS VARIABLE-GLOBALLY-SPECIAL-P MACRO ((VARIABLE) (GET VARIABLE 'GLOBALLY-SPECIAL))) (PUTPROPS VARIABLE-GLOBAL-P MACRO ((VARIABLE) (GET VARIABLE 'GLOBALVAR))) ) (CL:DEFUN XCL::DECL-SPECIFIER-P (CL:SYMBOL) (GET CL:SYMBOL 'SI::DECLARATION-SPECIFIER)) (CL:DEFUN XCL::SET-DECL-SPECIFIER-P (XCL::SPEC XCL::VAL) (CL:SETF (GET XCL::SPEC 'SI::DECLARATION-SPECIFIER) XCL::VAL)) (CL:DEFUN XCL::GLOBALLY-NOTINLINE-P (XCL::FN) (GET XCL::FN 'SI::GLOBALLY-NOTINLINE)) (CL:DEFUN XCL::SET-GLOBALLY-NOTINLINE-P (XCL::FN XCL::VAL) (CL:SETF (GET XCL::FN 'SI::GLOBALLY-NOTINLINE) XCL::VAL)) (CL:DEFSETF XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P) (CL:DEFSETF XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P) (PUTPROPS GLOBALLY-SPECIAL PROPTYPE IGNORE) (PUTPROPS GLOBALVAR PROPTYPE IGNORE) (PUTPROPS SI::DECLARATION-SPECIFIER PROPTYPE IGNORE) (PUTPROPS SI::GLOBALLY-NOTINLINE PROPTYPE IGNORE) (PUTPROPS SPECIAL-FORM PROPTYPE IGNORE) (PUTPROPS CMLEVAL FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLEVAL MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) (DECLARE\: EVAL@COMPILE DONTCOPY (DEFOPTIMIZER CL-EVAL-FN3-CALL (ARG1 ARG2 &ENVIRONMENT ENV) (* |;;| "Emit a call to FN3 after pushing only 2 arguments (the other having been pushed by IL:.COMPILER-SPREAD-ARGUMENTS. earlier in the game). Used in CL:EVAL.") (COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES FN3 0 0 0 (FN . \\EVAL-INVOKE-LAMBDA) RETURN) ,ARG1 ,ARG2)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES FN3 0 0 (FN . \\EVAL-INVOKE-LAMBDA) RETURN) ,ARG1 ,ARG2)) (T `((OPCODES FN3 0 (FN . \\EVAL-INVOKE-LAMBDA) RETURN) ,ARG1 ,ARG2)))) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA CL:TAGBODY CL:UNWIND-PROTECT CL:CATCH CL:SETQ CL:BLOCK CL:EVAL-WHEN CL:COMPILER-LET COMMON-LISP) (ADDTOVAR NLAML CL:THROW CL:FUNCTION CL:RETURN-FROM CL:IF) (ADDTOVAR LAMA CL:APPLY CL:FUNCALL) ) (PUTPROPS CMLEVAL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993)) (DECLARE\: DONTCOPY (FILEMAP (NIL (16590 16771 (COMMON-LISP 16600 . 16769)) (16810 22264 (\\TRANSLATE-CL\:LAMBDA 16820 . 22262)) (25766 50966 (CL:EVAL 25776 . 34711) (\\EVAL-INVOKE-LAMBDA 34713 . 35913) ( \\INTERPRET-ARGUMENTS 35915 . 47331) (\\INTERPRETER-LAMBDA 47333 . 48020) (CHECK-BINDABLE 48022 . 48678) (CHECK-KEYWORDS 48680 . 50964)) (51110 51755 (DECLARED-SPECIAL 51120 . 51753)) (51820 52506 ( CL:FUNCALL 51830 . 51993) (CL:APPLY 51995 . 52504)) (54754 56393 (CL:COMPILER-LET 54764 . 55558) ( COMP.COMPILER-LET 55560 . 56391)) (63209 63498 (CL:EVAL-WHEN 63219 . 63496)) (63925 64325 ( \\EVAL-PROGN 63935 . 64323)) (67720 71340 (\\LET*-RECURSION 67730 . 69073) (|\\LETtran| 69075 . 71338) ) (73162 73424 (CL:IF 73172 . 73422)) (75753 75917 (CL:BLOCK 75763 . 75915)) (76563 77808 ( CL:RETURN-FROM 76573 . 77806)) (79253 79554 (CL:FUNCTION 79263 . 79552)) (84577 84797 (COMP.CL-EVAL 84587 . 84795)) (86277 87489 (CL:CONSTANTP 86287 . 87487)) (88889 89579 (CL:SETQ 88899 . 89577)) ( 89832 91441 (SET-SYMBOL 89842 . 91439)) (92634 93303 (CL:THROW 92644 . 92857) (CL:CATCH 92859 . 93069) (CL:UNWIND-PROTECT 93071 . 93301)) (94809 95158 (CL:TAGBODY 94819 . 95156)) (95194 96093 (CACHEMACRO 95204 . 96091))))) STOP