From d45438dce90e360be7159d1fce221cf64e61d912 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Wed, 5 Nov 2003 17:32:45 +0000
Subject: [PATCH] Sending arguments via the lisp stack to a local function with
 lexical and closure environments did not work. Example of failed code
 (funcall     (compile nil             '(lambda (a b c)                (labels
 ((%f6 (f6-1 f6-2) c))                  (multiple-value-call #'%f6 (values a
 c)))))     0 10 20)

---
 src/cmp/cmpflet.lsp  | 45 ++++++++++++++++++++++++++++----------------
 src/cmp/cmpmulti.lsp |  2 ++
 2 files changed, 31 insertions(+), 16 deletions(-)

diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp
index 3a003afe4..04f1e4863 100644
--- a/src/cmp/cmpflet.lsp
+++ b/src/cmp/cmpflet.lsp
@@ -306,26 +306,39 @@
 	    (closure-p (fun-closure fun))
 	    (fname (fun-name fun)))
 	(unwind-exit
-	 (if (eq 'ARGS-PUSHED args)
-	     (list 'CALL-LOCAL "APPLY" lex-level closure-p
-		   (list fun `(STACK-POINTER ,narg)) narg fname)
-	     (list 'CALL-LOCAL fun lex-level closure-p
-		   (coerce-locs (inline-args args)) narg fname)))
+	 (list 'CALL-LOCAL fun lex-level closure-p
+	       (if (eq args 'ARGS-PUSHED) 'ARGS-PUSHED (coerce-locs (inline-args args)))
+	       narg fname))
 	(close-inline-blocks)))))
 
 (defun wt-call-local (fun lex-lvl closure-p args narg fname)
   (declare (fixnum lex-lvl))
-  ;; if NARG is non-NIL it is location containing narg
-  (wt fun "(" (or narg (length args)))
-  (when (plusp lex-lvl)
-    (dotimes (n lex-lvl)
-      (wt ",lex" n)))
-  (when closure-p
-    ;; env of local fun is ALWAYS contained in current env (?)
-    (wt ", env" *env-lvl*))
-  (dolist (arg args)
-    (wt "," arg))
-  (wt ")")
+  (cond ((not (eq args 'ARGS-PUSHED))
+	 ;; if NARG is non-NIL it is location containing narg
+	 (wt fun "(" (or narg (length args)))
+	 (when (plusp lex-lvl)
+	   (dotimes (n lex-lvl)
+	     (wt ",lex" n)))
+	 (when closure-p
+	   ;; env of local fun is ALWAYS contained in current env (?)
+	   (wt ", env" *env-lvl*))
+	 (dolist (arg args)
+	   (wt "," arg))
+	 (wt ")"))
+	((not narg)
+	 ;; When getting arguments from lisp stack, a location with the number
+	 ;; of arguments must have been supplied
+	 (baboon))
+	((not (or (plusp lex-lvl) closure-p))
+	 (wt "APPLY(" narg "," fun "," `(STACK-POINTER ,narg) ")"))
+	(t
+	 (wt "(")
+	 (when (plusp lex-lvl)
+	   (dotimes (n lex-lvl)
+	     (wt "cl_stack_push(lex" n ")," narg "++,")))
+	 (when closure-p
+	   (wt "cl_stack_push(env" *env-lvl* ")," narg "++,"))
+	 (wt-nl "  APPLY(" narg "," fun "," `(STACK-POINTER ,narg) "))")))
   (when fname (wt-comment fname)))
 
 
diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp
index 36f83b264..93886ec82 100644
--- a/src/cmp/cmpmulti.lsp
+++ b/src/cmp/cmpmulti.lsp
@@ -15,6 +15,8 @@
 (defun c1multiple-value-call (args &aux info funob)
   (check-args-number 'MULTIPLE-VALUE-CALL args 1)
   (cond ((endp (rest args)) (c1funcall args))
+	;; FIXME! We should optimize
+	;; (multiple-value-call ... (values a b c ...))
         (t (setq funob (c1funob (first args)))
            (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))