From ce56bcab70f4552a0b934b42c6c6ef9779eaa70e Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 24 Sep 1991 16:09:34 +0000
Subject: [PATCH] Fix to make unreferenced arguments in local call work.  We
 were correctly only popping (into the INTERNAL-APPLY arglist) the number of
 referenced args, but INTERNAL-APPLY was assuming that all arguments were
 present in the list.  Added a flag to INTERNAL-APPLY to control this
 behavior. This was breaking full call to interpreted functions as well, since
 the XEP did a local call to the main entry.

---
 compiler/eval.lisp | 38 +++++++++++++++++++++++---------------
 1 file changed, 23 insertions(+), 15 deletions(-)

diff --git a/compiler/eval.lisp b/compiler/eval.lisp
index d23633273..3992ee028 100644
--- a/compiler/eval.lisp
+++ b/compiler/eval.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.18 1991/04/22 23:05:05 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.19 1991/09/24 16:09:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -407,7 +407,8 @@
 		      (:local `(internal-apply
 				,lambda ,args-form
 				(compute-closure node ,lambda frame-ptr
-						 closure)))))
+						 closure)
+				nil))))
 	 (tailp-call-form
 	  (ecase call-type
 	    (:full `(return-from
@@ -423,7 +424,8 @@
 		       (eval-stack-set-top frame-ptr)
 		       (return-from
 			internal-apply-loop 
-			(internal-apply ,lambda ,args ,calling-closure)))))))
+			(internal-apply ,lambda ,args ,calling-closure
+					nil)))))))
     `(cond ((c::node-tail-p node)
 	    ,tailp-call-form)
 	   (t
@@ -754,21 +756,28 @@
 ;;; for this lambda's call frame.  Then store the args into locals on the
 ;;; stack.
 ;;;
-(defun internal-apply (lambda args closure)
+;;; Args is the list of arguments to apply to.  If IGNORE-UNUSED is true, then
+;;; values for un-read variables are present in the argument list, and must be
+;;; discarded (always true except in a local call.)  Args may run out of values
+;;; before vars runs out of variables (in the case of an XEP with optionals);
+;;; we just do CAR of nil and store nil.  This is not the proper defaulting
+;;; (which is done by explicit code in the XEP.)
+;;;
+(defun internal-apply (lambda args closure &optional (ignore-unused t))
   (let ((frame-ptr *eval-stack-top*))
     (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
     (do ((vars (c::lambda-vars lambda) (cdr vars))
-	 (args args (cdr args)))
+	 (args args))
 	((null vars))
-      ;; Args may run out of values before vars runs out of variables, so
-      ;; just do CAR of nil and store nil.
       (let ((var (car vars)))
-	(when (c::leaf-refs var)
-	  (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
-		(if (c::lambda-var-indirect var)
-		    (make-indirect-value-cell (car args))
-		    (car args))))))
-    (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args closure)))
+	(cond ((c::leaf-refs var)
+	       (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
+		     (if (c::lambda-var-indirect var)
+			 (make-indirect-value-cell (pop args))
+			 (pop args))))
+	      (ignore-unused (pop args)))))
+    (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args
+			 closure)))
 
 ;;; INTERNAL-APPLY-LOOP -- Internal.
 ;;;
@@ -935,8 +944,7 @@
 		 (change-blocks))
 		(t
 		 ;; Cif nodes set the block for us, but other last nodes do not.
-		 (change-blocks (car (c::block-succ block)))))))
-    (eval-stack-set-top frame-ptr)))
+		 (change-blocks (car (c::block-succ block)))))))))
 
 ;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal.
 ;;;
-- 
GitLab