1;;; -*- *cold-load:t; 1Mode: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.*
;;; 04/11/89	jlm	Changed usage of (PUTPROP ... to (SETF (GET ...


(DEFUN ZL-APPLY-LAMBDA (fctn a-value-list)

  (BLOCK apply-lambda (PROG ()
	(or (consp fctn) (go bad-function))
     tail-recurse
	(cond 
	  ((MEMBER (car fctn) '(GLOBAL:lambda GLOBAL:named-lambda GLOBAL:subst GLOBAL:named-subst) :TEST #'EQ)
	   (WHEN (OR (ZLC:MEMQ (CAR fctn) '(GLOBAL:named-lambda GLOBAL:named-subst))
		     (COMMON-LISP-ON-P))
	     (SET-ZETALISP-BINDINGS)
	     (bind (locf *INTERPRETER-ENVIRONMENT*) nil)
	     (bind (locf *INTERPRETER-FUNCTION-ENVIRONMENT*) NIL))
	   (let* (optionalf quoteflag tem restf init this-restf
		  (fctn (cond ((eq (car fctn) 'GLOBAL:named-lambda) (cdr fctn))
			      ((eq (car fctn) 'GLOBAL:named-subst) (cdr fctn))
			      (t fctn)))
		  (lambda-list (cadr fctn))
		  (value-list a-value-list)
		  (local-declarations local-declarations)
		  keynames keyinits keykeys keyflags
		  keynames1 keykeys1 keyflags1 (unspecified '(()))
		  allow-other-keys)
	     (setq fctn (cddr fctn))		;throw away lambda list
	     (do-forever
	       (cond ((and (cdr fctn) (stringp (car fctn)))
		      (pop fctn))		;and doc string.
		     ;; Process any (DECLARE) at the front of the function.
		     ;; This does not matter for SPECIAL declarations,
		     ;; but for MACRO declarations it might be important
		     ;; even in interpreted code.
		     ((and (not (atom (car fctn)))
			   (ZLC:MEMQ (caar fctn) '(declare :declare)))
		      (setq local-declarations (append (cdar fctn) local-declarations))
		      (pop fctn))
		     (t (return))))
	     (prog ()
		   ;; If SELF is an instance, and its instance vars aren't bound, bind them.
		   (and (typep self 'instance)
			(neq self slots-bound-instance)
			(progn (%using-binding-instances (self-binding-instances))
			       (bind (locf slots-bound-instance) self)))
		l    (cond ((null value-list) (go lp1))
			   ((or (null lambda-list)
				(eq (car lambda-list) '&aux)) 
			    (cond (restf (go lp1))
				  (t (go too-many-args))))
			   ((eq (car lambda-list) '&key)
			    (go key))
			   ((eq (car lambda-list) '&optional)
			    (setq optionalf t)
			    (go l1))		;Do next value.
			   ((ZLC:MEMQ (car lambda-list) '(&quote &eval))
			    (setq quoteflag (eq (car lambda-list) '&quote))
			    (go l1))
			   ((eq (car lambda-list) '&rest)
			    (setq this-restf t)
			    (go l1))		;Do next value.
			   ((ZLC:MEMQ (car lambda-list) lambda-list-keywords)
			    (go l1))
			   ((atom (car lambda-list)) (setq tem (car lambda-list)))
			   ((atom (caar lambda-list))
			    (setq tem (caar lambda-list))
			    ;; If it's &OPTIONAL (FOO NIL FOOP),
			    ;; bind FOOP to T since FOO was specified.
			    (cond ((and optionalf (cddar lambda-list))
				   (and (null (caddar lambda-list)) (go bad-lambda-list))
				   (bind (value-cell-location (caddar lambda-list)) t))))
			   (t (go bad-lambda-list)))
		   ;; Get here if there was a real argname in (CAR LAMBDA-LIST).
		   ;;  It is in TEM.
		   (and (null tem) (go bad-lambda-list))
		   (cond (restf (go bad-lambda-list))	;Something follows a &REST arg???
			 (this-restf		;This IS the &REST arg.
			  ;; If quoted arg, and the list of values is in a pdl, copy it.
			  (and quoteflag
			       (region-pdl-buffer-p (%REGION-NUMBER value-list))
			       (let ((default-cons-area background-cons-area))
				 (setq value-list (copy-list value-list))))
			  (bind (locf (SYMBOL-VALUE tem)) value-list)
			  ;; We don't clear out VALUE-LIST
			  ;; in case keyword args follow.
			  (setq this-restf nil restf t)
			  (go l1)))
		   (bind (value-cell-location tem) (car value-list))
		   (setq value-list (cdr value-list))
		l1   (setq lambda-list (cdr lambda-list))
		   (go l)
		   
		key  (MULTIPLE-VALUE-SETQ ( nil nil lambda-list nil nil
				   keykeys keynames nil keyinits keyflags
				   allow-other-keys)
			   (decode-keyword-arglist lambda-list))
		   ;; Process the special keyword :ALLOW-OTHER-KEYS if present as an arg.
		   (if (get (locf value-list) ':allow-other-keys)
		       (setq allow-other-keys t))
		   
		   (setq keykeys1 keykeys	;life is tough without LET...
			 keynames1 keynames
			 keyflags1 keyflags)
		key1 (when keykeys1
		       (setq tem (get (locf value-list) (pop keykeys1) unspecified))
		       (bind (locf (SYMBOL-VALUE (car keynames1)))
			     (if (eq tem unspecified) (*EVAL (car keyinits))
				 tem))
		       (if (car keyflags1)
			   (bind (locf (SYMBOL-VALUE (car keyflags1))) (neq tem unspecified)))
		       (pop keynames1)
		       (pop keyflags1)
		       (pop keyinits)
		       (go key1))
		   (do ((x value-list (cddr x))
			keyword)
		       ((null x))
		     (unless (cdr x)
		       (ferror 'sys:bad-keyword-arglist
			       "No argument after keyword ~S"
			       (car x)))
		     (setq keyword (car x))
		     (setq tem (POSITION keyword (THE LIST keykeys) :TEST #'EQ))
		     (unless (or tem allow-other-keys)
		       (do-forever
			 (setq keyword (cerror ':new-keyword nil
					       'sys:undefined-keyword-argument
					       "Keyword arg keyword ~S, with value ~S, is unrecognized."
					       keyword
					       (cadr value-list)))
			 (when (and keyword (setq tem (POSITION keyword (THE LIST keykeys) :TEST #'EQ)))
			   (set (nth tem keynames) (cadr x))
			   (and (setq tem (nth tem keyflags))
				(set tem t))
			   (return)))))
		   ;; Keyword args always use up all the values that are left...
		   
		   ;; Here when all values used up.
		lp1  (cond ((null lambda-list) (go ex1))
			   ((eq (car lambda-list) '&rest)
			    (and restf (go bad-lambda-list))
			    (setq this-restf t)
			    (go lp2))
			   ((eq (car lambda-list) '&key)
			    (go key))
			   ((ZLC:MEMQ (car lambda-list) '(&optional &aux))
			    (setq optionalf t)	;Suppress too few args error
			    (go lp2))
			   ((ZLC:MEMQ (car lambda-list) lambda-list-keywords)
			    (go lp2))
			   ((and (null optionalf) (null this-restf))
			    (and restf (go bad-lambda-list))
			    (go too-few-args))
			   ((atom (car lambda-list)) (setq tem (car lambda-list))
						     (setq init nil))
			   ((atom (caar lambda-list))
			    (setq tem (caar lambda-list))
			    (setq init (*EVAL (cadar lambda-list)))
			    ;; For (FOO NIL FOOP), bind FOOP to NIL since FOO is missing.
			    (cond ((cddar lambda-list)
				   (and (null (caddar lambda-list)) (go bad-lambda-list))
				   (bind (value-cell-location (caddar lambda-list)) nil))))
			   (t (go bad-lambda-list)))
		lp3  (and (null tem) (go bad-lambda-list))
		   (bind (value-cell-location tem) init)
		   (and this-restf (setq restf t))
		   (setq this-restf nil)
		lp2  (setq lambda-list (cdr lambda-list))
		   (go lp1)
		   
		ex1  (do ((l fctn (cdr l)))
			 ((null (cdr l))
			  (return-from apply-lambda (*EVAL (car l))))
		       (*EVAL (car l))))))
	  ((eq (car fctn) 'macro)
	   (ferror 'sys:funcall-macro
		   "Funcalling the macro ~S."
		   (function-name (cdr fctn)))
	   (return-from apply-lambda
	     (*EVAL (cons fctn (mapcar #'(lambda (arg) `',arg) a-value-list)))))
	  )
	
	;; A list, but don't recognize the keyword.  Check for a LAMBDA position macro.
	(cond ((lambda-macro-call-p fctn)
	       (setq fctn (lambda-macro-expand fctn))
	       (go retry)))
	
     bad-function
	;; Can drop through to here for a totally unrecognized function.
	(setq fctn
	      (cerror ':new-function nil 'sys:invalid-function
		      "~S is an invalid function." fctn))
	(go retry)
	
	;; Errors jump out of the inner PROG to unbind any lambda-vars bound with BIND.
	
     bad-lambda-list
	(setq fctn
	      (cerror ':new-function nil 'sys:invalid-lambda-list
		      "~S has an invalid LAMBDA list" fctn))
     retry
	(and (consp fctn) (go tail-recurse))
	(return (apply fctn a-value-list))
	
     too-few-args
	(return (signal-proceed-case
		  ((args)
		   (make-condition 'sys:too-few-arguments
				   "Function ~S called with only ~D argument~1G~P."
				   fctn (length a-value-list) a-value-list))
		  (:additional-arguments
		   (apply fctn (append a-value-list args)))
		  (:return-value args)
		  (:new-argument-list (apply fctn args))))
	
     too-many-args
	(return (signal-proceed-case
		  ((args)
		   (make-condition 'sys:too-many-arguments
				   "Function ~S called with too many arguments (~D)."
				   fctn (length a-value-list) a-value-list))
		  (:fewer-arguments
		   (apply fctn (append a-value-list args)))
		  (:return-value args)
		  (:new-argument-list (apply fctn args)))))))


;; this procedure is used in zl-apply-lambda
;DECODE-KEYWORD-ARGLIST

;Given a lambda list, return a decomposition of it and a description
;of all the keyword args in it.
;POSITIONAL-ARGS is the segment of the front of the arglist before any keyword args.
;KEYWORD-ARGS is the segment containing the keyword args.
;AUXVARS is the segment containing the aux vars.
;REST-ARG is the name of the rest arg, if any, else nil.
;POSITIONAL-ARG-NAMES is a list of all positional args
; and the supplied-flags of all optional positional args.
;The rest of the values describe the keyword args.
;There are several lists, equally long, with one element per arg.
;KEYNAMES contains the keyword arg variable names.
;KEYKEYS contains the key symbols themselves (in the keyword package).
;KEYOPTFS contains T for each optional keyword arg, NIL for each required one.
;KEYINITS contains for each arg the init-form, or nil if none.
;KEYFLAGS contains for each arg its supplied-flag's name, or nil if none.
;Finally,
;ALLOW-OTHER-KEYS is T if &ALLOW-OTHER-KEYS appeared among the keyword args.
(defun decode-keyword-arglist (lambda-list)
  (declare (VALUES positional-args keyword-args auxvars
			rest-arg positional-arg-names
			keykeys keynames keyoptfs keyinits keyflags allow-other-keys))
  (let (positional-args keyword-args auxvars
	optionalf this-rest rest-arg positional-arg-names
	keykeys keynames keyoptfs keyinits keyflags allow-other-keys)
    (setq auxvars (MEMBER '&aux lambda-list :TEST #'EQ))
    (setq positional-args (ldiff lambda-list auxvars))
    (setq keyword-args (MEMBER '&key positional-args :TEST #'EQ))
    (setq positional-args (ldiff positional-args keyword-args))

    (setq keyword-args (ldiff keyword-args auxvars))
    ;; Get names of all positional args and their supplied-flags.
    ;; Get name of rest arg if any.  Find out whether they end optional.
    (dolist (a positional-args)
      (cond ((eq a '&optional) (setq optionalf t))
	    ((eq a '&rest) (setq this-rest t))
	    ((LAMBDA-LIST-KEYWORD-P a))
	    (t (cond ((symbolp a) (push a positional-arg-names))
		     (t (and (cddr a) (push (caddr a) positional-arg-names))
			(push (car a) positional-arg-names)))
	       (and this-rest (not rest-arg) (setq rest-arg (car positional-arg-names))))))
    (setq positional-arg-names (nreverse positional-arg-names))
    ;; Decode the keyword args.  Set up keynames, keyinits, keykeys, keyflags.
    (dolist (a (cdr keyword-args))
      (cond ((eq a '&optional) (setq optionalf t))
	    ((eq a '&allow-other-keys) (setq allow-other-keys t))
	    ((LAMBDA-LIST-KEYWORD-P a))
	    (t (let (keyname keyinit keyflag keykey)
		 (if (and (consp a) (consp (car a)))
		     ;; Key symbol specified explicitly.
		     (setq keykey (caar a) keyname (cadar a))
		   ;; Else determine it from the variable name.
		   (setq keyname (if (consp a) (car a) a))
		   (or (setq keykey (get keyname 'keykey))
		       (progn (setq keykey (intern (SYMBOL-NAME keyname)
						   si:*KEYWORD-PACKAGE*))
			      ;;(putprop keyname keykey 'keykey)		; jlm 4/11/89
			      (setf (get keyname 'keykey) keykey))))
		 (if (consp a)
		     (setq keyinit (cadr a) keyflag (caddr a)))
		 (push keyname keynames)
		 (push optionalf keyoptfs)
		 (push keyinit keyinits)
		 (push keyflag keyflags)
		 (push keykey keykeys)))))
    ;; Get everything about the keyword args back into forward order.
    (setq keynames (nreverse keynames)
	  keyinits (nreverse keyinits)
	  keyoptfs (nreverse keyoptfs)
	  keykeys (nreverse keykeys)
	  keyflags (nreverse keyflags))
    (values positional-args keyword-args auxvars
	    rest-arg positional-arg-names
	    keykeys keynames keyoptfs keyinits keyflags allow-other-keys)))

(DEFUN TOO-FEW-ARGS-ERROR (function argument-list)
  (SIGNAL-PROCEED-CASE
    ((args)
     (MAKE-CONDITION 'sys:too-few-arguments
		     "Function ~S kalled with only ~D argument~1G~P."
		     function (LENGTH argument-list) argument-list))
    (:additional-arguments 
     (APPLY function (APPEND argument-list args)))
    (:new-argument-list 
     (APPLY function args))))

(DEFUN TOO-MANY-ARGS-ERROR (function argument-list)
  
  (SIGNAL-PROCEED-CASE
    ((args)
     (MAKE-CONDITION 'sys:too-many-arguments
		     "Function ~S called with too many arguments (~D)."
		     function (LENGTH argument-list) argument-list))
    (:fewer-arguments
     (APPLY function (APPEND argument-list args)))
    (:return-value args)
    (:new-argument-list (APPLY function args))))

;;;PHD 3/11/87 Fixed call to (%p-store-data-type-and-pointer, follow copied stack-lists
;;; the following macros are used in apply-lambda
;; assumes SPECIALS, BFRAME, NEXTSLOT and SPECIALVAR are bound in the environment of the user.

(eval-when (compile)
  (DEFMACRO BIND-LAMBDA-VARIABLE (symbol value)
    `(PROGN
       (UNLESS (VARIABLE-P ,symbol) (BINDING-ERROR ,symbol))
       (SETF (CAR nextslot)
	     (SETQ symbol-loc (VALUE-CELL-LOCATION ,symbol))) ;; car of slot is locative
       (COND ((OR (SPECIAL-VAR-P ,symbol specials) specialvar)
;; TGC	      (%P-STORE-DATA-TYPE (LOCF (CADR nextslot)) DTP-EXTERNAL-VALUE-CELL-POINTER)
;;	      (%P-STORE-POINTER (LOCF (CADR nextslot)) symbol-loc)
	      (%p-store-data-type-and-pointer
		(if (/= DTP-EXTERNAL-VALUE-CELL-POINTER (%p-data-type (LOCF (CADR nextslot))))
		    (LOCF (CADR nextslot))
		    (%P-CONTENTS-AS-LOCATIVE (LOCF (CADR nextslot))))
		DTP-EXTERNAL-VALUE-CELL-POINTER symbol-loc)
	      (BIND symbol-loc ,value))           ;; bind symbol to its value
	     (t (SETF (CADR nextslot) ,value)))   ;; make lexical binding
       (SETQ nextslot (CDDR nextslot))))

  (DEFMACRO BIND-INSTANCE-VARIABLE (locative value)
    `(PROGN
       (SETF (CAR nextslot) ,locative)
       (SETF (CADR nextslot) ,value)
       (%P-STORE-DATA-TYPE (if (/= DTP-EXTERNAL-VALUE-CELL-POINTER (%p-data-type (LOCF (CADR nextslot))))
			       (LOCF (CADR nextslot))
			       (%P-CONTENTS-AS-LOCATIVE (LOCF (CADR nextslot))))
			   DTP-EXTERNAL-VALUE-CELL-POINTER)
       (SETQ nextslot (CDDR nextslot))))  ;; update pointer to frame

;; the following macro defines a control structure of the simplest nature:
;;  (repeat-while [condition] body)
;; which executes the body only so long as the condition remains true, i.e. non-nil.
;;

  (DEFMACRO REPEAT-WHILE (condition &BODY body)
    (LET ((loopbegin (GENSYM))(testcond (GENSYM)))
      `(TAGBODY
	   (GO ,testcond) ;; test condition BEFORE executing body
	   ,loopbegin     ;; loop starts here
	   ,@body
	   ,testcond
	   (WHEN ,condition (GO ,loopbegin)))))

  (DEFMACRO DO-KEYWORD-CHECK ()
    `(DO ((x restargl (CDDR x)))
	 ((ATOM x))
       (UNLESS (MEMBER (CAR x) keywords-already-seen :TEST #'EQ)
	 (DO ((y x (CDDR y)))
	     ((ATOM y)
	      (FERROR nil "keyword ~s not recognized by ~s" (CAR x) fctn))
	   (IF (AND (EQ (CAR y) :ALLOW-OTHER-KEYS) (CADR y))
	       (RETURN (SETQ check-keywords nil x nil)))))))
  )

1;;; APPLY-LAMBDA is invoked from the ucode when the latter processes a function call and discovers 
;;; that the function to be called is a list.  It should be stressed that APPLY-LAMBDA is not called 
;;; from any Lisp-world function. When called, its formal arguments <fctn> and <arglist> are bound 
;;; respectively to a function object, known to be a list, and a list of arguments to which the 
;;; function is to be applied. APPLY-LAMBDA binds the formal arguments of <fctn>
;;; to the arguments in <arglist>, evaluates the body of the function  and returns all of its results.*

(DEFUN APPLY-LAMBDA (fctn arglist)

  (LET
    ((*INTERPRETER-ENVIRONMENT* *INTERPRETER-ENVIRONMENT*) ;; establish new bindings for ENV
     (*INTERPRETER-FUNCTION-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*)
     fctname					; name of function
     specials					; list of variables declared specialin function body
     lambda-list				; lambda-list of function
     body					; body of function including declarations
     (size 0)
     bframe
     instance-bindings)

    (UNLESS (EQ (CAR fctn) 'CLOSURE-NAMED-LAMBDA)
      (SETQ *INTERPRETER-ENVIRONMENT* nil    ;; clear existing lexical environment to achieve lexical scoping
	     *INTERPRETER-FUNCTION-ENVIRONMENT* nil))
    (COND
      ;; process a DEFUN, DEFSUBST or DEFMETHOD
      ((MEMBER (CAR fctn) '(NAMED-LAMBDA CLOSURE-NAMED-LAMBDA NAMED-SUBST) :TEST #'EQ)
       (SETQ fctname (CADR fctn)            ;; extract function name
	     lambda-list (CADDR fctn)       ;; extract lambda list
	     body (CDDDR fctn))             ;; extract declarations+function body
       (WHEN (AND (CONSP fctname) (CONSP (CAR fctname)) (EQ (CAAR fctname) :method))
	 (SETQ  instance-bindings (SELF-BINDING-INSTANCES)
		size (LENGTH instance-bindings))))
      ;; process an anonymous lambda
      ((MEMBER (CAR fctn) '(CLI:LAMBDA CLI:SUBST) :TEST #'EQ)
       (SETQ lambda-list (CADR fctn)       ;; extract only lambda list and body
	     body (CDDR fctn)))            ;; evaluation proceeds using existing lexical environment
      
      ((MEMBER (CAR fctn) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA GLOBAL:SUBST GLOBAL:NAMED-SUBST) :TEST #'EQ)
       (RETURN-FROM APPLY-LAMBDA (ZL-APPLY-LAMBDA fctn arglist)))
      (t (IF (EQ (CAR fctn) 'MACRO)
	     (FERROR nil "Attempting to call the macro ~s as a function." (FUNCTION-NAME (CDR fctn)))
	     (FERROR nil "~s is an ill-formed function object " fctn))))
    
    (IF (ZETALISP-ON-P) (SET-COMMON-LISP-BINDINGS))
			    
1;;; ENTERING FUNCTION OBJECT - add a basic frame consisting of nil's
;;;     to the front of the lexical environment. The size of the frame includes the length
;;;     of the instance-bindings list, plus twice the length of the list of declared specials
;;;     plus the length of the lambda list. *
    
    (SETQ specials (EXTRACT-SPECIAL-DECLARATIONS))   ;; extract any special declarations
    
    (SETQ size (+ size (* 2 (LENGTH specials))
		  (DO ((x lambda-list (CDR x))
		       (y 0)
		       z)
		      ((ATOM x) (* 2 y))
		    (SETQ z (CAR x))
		    (INCF y 
			  (COND ((LAMBDA-LIST-KEYWORD-P z) 0)
				((SYMBOLP z) 1)
				((CONSP z) (IF (NTHCDR 2 z) 2 1))
				(t 1))))))
    
    
    (SETQ bframe (%MAKE-STACK-LIST size))
    
    (WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* bframe *INTERPRETER-ENVIRONMENT*)
      
;       (PRINT-ENVIRONMENT)
      
      (PROG* 
	((nextslot bframe) ;; points to nextslot in the basic frame
	 arg           ;; next arg in arglist
	 (arg-count 0) ;; number of processed arguments
	 (nargs (LENGTH arglist)) ;; number of arguments 
	 (restargl arglist) ;; remainder of argument list
	 optvar       ;; used to hold name of optional lambda-list var
	 (restvarlist lambda-list)
	 var
	 supplied-p  ;; a flag used to indicate the presence/absence of "supplied-p" parms
	 specialvar   ;; a flag used to indicate &SPECIAL/&LOCAL declarations
	 found        ;;
	 symbol-loc   ;; locative to symbol being bound
	 key
	 keywords-already-seen
	 (check-keywords *interpreter-maximum-error-checking*))
	
;;; REQUIRED PARM PROCESSING - enter here initially
	
	(REPEAT-WHILE instance-bindings
	  (SETQ var (CAR instance-bindings) 
		arg (CADR instance-bindings)
		instance-bindings (CDDR instance-bindings))
	  (BIND-INSTANCE-VARIABLE var arg))
	
	(REPEAT-WHILE restvarlist
	  (SETQ var (POP restvarlist))   ;; extract next variable
	  (IF (LAMBDA-LIST-KEYWORD-P var)   ;; if keyword, which one?
	      (CASE var
		    (&OPTIONAL     (GO OPTIONAL-PARM-LOOP))
		    (&REST         (GO REST-PARM-LOOP))
		    (&KEY          (GO KEY-PARM-LOOP))
		    (&AUX          (GO AUX-PARM-PROCESSING))
		    (&SPECIAL      (SETQ specialvar t))
		    (&LOCAL        (SETQ specialvar nil))
		    ((&QUOTE &EVAL &FUNCTIONAL &EXTENSION) nil)
		    (t (FERROR nil "mis-placed keyword ~s in function ~s" var fctn)))
	      (COND     ;; else check variable and bind value
		((< arg-count nargs)
		 (SETQ arg (POP restargl))
		 (INCF arg-count)
		 (BIND-LAMBDA-VARIABLE var arg))
		(t  ;; else missing some required args
		 (RETURN-FROM APPLY-LAMBDA (TOO-FEW-ARGS-ERROR fctn arglist))))))
	
	;; the only way we can get here is if RESTVARLIST is nil,i.e. there are no more
	;; variables to bind in the lambda list 
	
	(IF (OR (= arg-count nargs) (NOT *INTERPRETER-MAXIMUM-ERROR-CHECKING*))
	    (GO PROCESS-BODY)
	    ;; else signal continuable error
	    (RETURN-FROM APPLY-LAMBDA (TOO-MANY-ARGS-ERROR fctn arglist)))
	
	
;;; &OPTIONAL PROCESSING - enter here ONLY from REQUIRED-PARM-LOOP and then
;;;     only if the keyword &OPTIONAL is seen
	
;;; note: an optional parameter may assume one of the forms 
;;;            var|(var)|(var default)|(var default supplied-p)
	
     OPTIONAL-PARM-LOOP   ;; *** go-tag for optional parameter processing
	
	(REPEAT-WHILE restvarlist
	  (SETQ optvar (POP restvarlist))   ;; extract next variable and place in optvar
	  (IF (LAMBDA-LIST-KEYWORD-P optvar)   ;; if keyword, find which one
	      (CASE optvar
		    (&REST         (GO REST-PARM-LOOP))
		    (&KEY          (GO KEY-PARM-LOOP))
		    (&AUX          (GO AUX-PARM-PROCESSING))
		    (&SPECIAL      (SETQ specialvar t))
		    (&LOCAL        (SETQ specialvar nil))
		    ((&QUOTE &EVAL &FUNCTIONAL &EXTENSION) nil)
		    (t (FERROR nil "mis-placed keyword ~s in function ~s" var fctn)))
	      ;; else determine variable to be bound
	      (SETQ var (IF (CONSP optvar) (CAR optvar) optvar) 
		    arg  nil
		    found nil
		    supplied-p nil)
	      (WHEN (CONSP optvar)
		(WHEN (CDR optvar)
		  (SETQ arg (CADR optvar))  ;; arg is now default
		  (WHEN (CDDR optvar) (SETQ supplied-p (CADDR optvar)))))
	      (SETQ arg    ;; determine value of var
		    (COND
		      ((< arg-count nargs)  ;; bind var to an arg from arglist
		       (INCF arg-count)
		       (SETQ found t)   ;; in case "supplied-p"
		       (POP restargl))  ;; return arg from arglist
		      (arg              ;; if non-nil default
		       (*EVAL arg))     ;; return its value
		      (t nil)))
	      (BIND-LAMBDA-VARIABLE var arg)
	      (WHEN supplied-p (BIND-LAMBDA-VARIABLE supplied-p found))))
	
	(IF (OR (= arg-count nargs) (NOT *INTERPRETER-MAXIMUM-ERROR-CHECKING*))
	    (GO PROCESS-BODY)
	    ;; else signal continuable error
	    (RETURN-FROM APPLY-LAMBDA (TOO-MANY-ARGS-ERROR fctn arglist)))
	
;;; &KEY PROCESSING - enter here from REQUIRED-PARM-LOOP only if the keyword &OPTIONAL is seen
;	keyword parameters have one of the forms
;	  var | (var) | (var default) | (var default supplied-p) | ((:key var)) |
;	 ((:key var) default) | ((:key var) default supplied-p)
	
     KEY-PARM-LOOP

	(UNLESS (EVENP (- nargs arg-count))
	  (FERROR nil "unmatched keyword in ~s for function ~s"
		  arglist fctn))
	
	(REPEAT-WHILE restvarlist
	  (SETQ optvar (POP restvarlist))   ;; extract next variable and place in optvar		 
	  (IF (LAMBDA-LIST-KEYWORD-P optvar)   ;; if keyword, which one?
	      (CASE optvar
		    (&ALLOW-OTHER-KEYS (SETQ check-keywords nil))
		    (&AUX          
		     (WHEN check-keywords (DO-KEYWORD-CHECK))
		     (GO AUX-PARM-LOOP))
		    (&SPECIAL      (SETQ specialvar t))
		    (&LOCAL        (SETQ specialvar nil))
		    ((&QUOTE &EVAL &FUNCTIONAL &EXTENSION) nil)
		    (t (FERROR nil "mis-placed keyword ~s in function ~s" optvar fctn)))
	      ;; else
	      (SETQ arg nil supplied-p nil found nil)
	      (COND
		((CONSP optvar)                         ;; processing (...)
		 (COND
		   ((CONSP (CAR optvar))                ;; processing ((...)...) 
		    (SETQ key (CAAR optvar) 
			  var (CADAR optvar))
		    (UNLESS (KEYWORDP key)
		      (FERROR nil "ill-formed keyword argument ~s in ~s" optvar fctn)))
		   (t 
		    (SETQ var (CAR optvar) 
			  key (INTERN (SYMBOL-NAME (CAR optvar)) *KEYWORD-PACKAGE*))))
		 (WHEN (CDR optvar)                     ;; (... default)
		   (SETQ arg (CADR optvar))
		   (WHEN (CDDR optvar)                  ;; (... default supplied-p) 
		     (SETQ supplied-p (CADDR optvar)))))
		(t 
		 (SETQ key (INTERN (SYMBOL-NAME optvar) *KEYWORD-PACKAGE*)
		       var optvar)))
	      ;; if something in RESTARGL, then search for KEY else use default
	      (SETQ arg 
		    (DO ((x restargl (CDDR x)))
			((ATOM x) (*EVAL arg)) ;; return default
		      (WHEN (EQ (CAR x) key)
			(SETQ found t)
			(RETURN (CADR x)))))  ;; return value
	      (BIND-LAMBDA-VARIABLE var arg)
	      (WHEN supplied-p (BIND-LAMBDA-VARIABLE supplied-p found ))
	      (WHEN check-keywords (PUSH key keywords-already-seen))))

	(WHEN check-keywords (DO-KEYWORD-CHECK))
	(GO PROCESS-BODY)
	
	
;;; &AUX PROCESSING - enter here from REQUIRED-PARM-LOOP, OPTIONAL-PARM-LOOP , AFTER-REST-WHERE-NEXT?
	
;;;   auxiliary parameters may assume one of the forms var |(var) | (var default)
	
     AUX-PARM-PROCESSING  ;; make certain all args are used up
	(UNLESS (OR (ATOM restargl) (NOT *INTERPRETER-MAXIMUM-ERROR-CHECKING*))
	  (RETURN-FROM APPLY-LAMBDA (TOO-MANY-ARGS-ERROR fctn arglist)))
	
     AUX-PARM-LOOP
	
	(REPEAT-WHILE restvarlist	 
	  (SETQ optvar (POP restvarlist))   ;; extract next variable and place in optvar
	  (IF (LAMBDA-LIST-KEYWORD-P optvar)   ;; if variable is a keyword, then test keyword
	      (CASE optvar
		    (&SPECIAL      (SETQ specialvar t))
		    (&LOCAL        (SETQ specialvar nil))
		    (t (FERROR nil "mis-placed keyword ~s in function ~s" var fctn)))
	      ;; else
	      (SETQ var (IF (CONSP optvar) (CAR optvar) optvar) 
		    arg nil)
	      (WHEN (CONSP optvar)
		(WHEN (CDR optvar)
		  (SETQ arg (*EVAL (CADR optvar)))))
	      (BIND-LAMBDA-VARIABLE var arg)))
	
	(GO PROCESS-BODY)  ;; if we get here, just process the body
	
;;; &REST PROCESSING - enter here from REQUIRED-PARM-LOOP, OPTIONAL-PARM-LOOP only if the keyword &REST is seen
	
     REST-PARM-LOOP  ;; this is a loop since ...&REST &LOCAL &QUOTE foo... is an obvious case
	
	(REPEAT-WHILE restvarlist
	  (SETQ var (POP restvarlist))
	  (IF (LAMBDA-LIST-KEYWORD-P var)   ;; if variable is a keyword, then test keyword
	      (CASE var
		    ((&QUOTE &EVAL &FUNCTIONAL &EXTENSION) nil)
		    (&SPECIAL      (SETQ specialvar t))
		    (&LOCAL        (SETQ specialvar nil))
		    (t (FERROR nil "mis-placed keyword ~s in function ~s" var fctn)))
	      ;; else bind rest arg to the remainder of the arglist 
	      ;; if no more vars, process body - otherwise determine where to go next
	      (BIND-LAMBDA-VARIABLE var restargl)
	      (IF (ATOM restvarlist) (GO PROCESS-BODY)
		  (GO AFTER-REST-WHERE-NEXT?))))
	
	(FERROR nil "improper &REST arg in ~s"  fctn) ;; getting here =>	nothing follows &rest
	
     AFTER-REST-WHERE-NEXT?
	(SETQ var (POP restvarlist)) ;; var must be a keyword
	(CASE var
	      (&KEY          (GO KEY-PARM-LOOP))
	      (&AUX          (GO AUX-PARM-LOOP)) ;; bypass "args exhausted" test
	      ((&QUOTE &EVAL &FUNCTIONAL &EXTENSION) nil)
	      (&SPECIAL      (SETQ specialvar t))
	      (&LOCAL        (SETQ specialvar nil))
	      (t (FERROR nil "illegal entry ~s follows &REST arg in function ~s" var fctn)))
	(GO AFTER-REST-WHERE-NEXT?)
	
;;; EVALUATE THE BODY - enter here from 
	
     PROCESS-BODY   ;; first add specials to the basic frame
	
	(REPEAT-WHILE specials
	  (SETQ var (CAR specials))
	  (UNLESS (SYMBOLP var) (BINDING-ERROR var))
	  (SETF (FIRST nextslot) (VALUE-CELL-LOCATION var))
	  (%p-store-data-type-and-pointer
	    (if (/= DTP-EXTERNAL-VALUE-CELL-POINTER (%p-data-type (locf (SECOND nextslot))))
		(locf (second nextslot))
		(%P-CONTENTS-AS-LOCATIVE (locf (second nextslot))))
	    DTP-EXTERNAL-VALUE-CELL-POINTER (VALUE