[movitz-cvs] CVS update: movitz/compiler.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv31166

Modified Files:
	compiler.lisp 
Log Message:
For 1req1opt functions (i.e. with arglist like (x &optional y)), make
the compiler not die in pain from certain situations. That is, we can
now deal with e.g. (defun foo (x &optional y) (lambda () y)) which
before we couldn't/wouldn't.

Date: Thu Jul 21 19:28:46 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.147 movitz/compiler.lisp:1.148
--- movitz/compiler.lisp:1.147	Thu Jun 16 22:55:42 2005
+++ movitz/compiler.lisp	Thu Jul 21 19:28:46 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.148 2005/07/21 17:28:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -848,28 +848,35 @@
 				 req-location opt-location)))
 		      (cond
 		       ((not optp-location)
-			())
-		       ((= optp-location (1+ stack-setup-pre))
-			(incf stack-setup-pre 1)
-			`((:pushl :edx)))
+			(make-stack-setup-code (- stack-frame-size stack-setup-pre)))
+		       ((and (integerp optp-location)
+			     (= optp-location (1+ stack-setup-pre)))
+			(append `((:pushl :edx))
+				(make-stack-setup-code (- stack-frame-size stack-setup-pre 1))))
+		       ((integerp optp-location)
+			(append (make-stack-setup-code (- stack-frame-size stack-setup-pre))
+				`((:movl :edx (:ebp ,(stack-frame-offset optp-location))))))
 		       (t (error "Can't deal with optional-p at ~S, after (~S ~S)."
 				 optp-location req-location opt-location)))
-		      (make-stack-setup-code (- stack-frame-size stack-setup-pre))
-		      (when (binding-lended-p req-binding)
-			(let ((lended-cons-position (getf (binding-lending req-binding)
-							  :stack-cons-location)))
-			  (etypecase req-location
-			    (integer
-			     `((:movl (:ebp ,(stack-frame-offset req-location)) :edx)
-			       (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr 
-			       (:movl :edx (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car
-			       (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position)))
-				      :edx)
-			       (:movl :edx (:ebp ,(stack-frame-offset req-location))))))))
-		      (when (binding-lended-p opt-binding)
-			(error "Can't deal with lending optional right now."))
-		      (when (and optp-binding (binding-lended-p optp-binding))
-			(error "Can't deal with lending optionalp right now."))
+		      (flet ((make-lending (location lended-cons-position)
+			       (etypecase req-location
+				 (integer
+				  `((:movl (:ebp ,(stack-frame-offset location)) :edx)
+				    (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr 
+				    (:movl :edx (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car
+				    (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position)))
+					   :edx)
+				    (:movl :edx (:ebp ,(stack-frame-offset location))))))))
+			(append
+			 (when (binding-lended-p req-binding)
+			   (make-lending req-location (getf (binding-lending req-binding)
+							    :stack-cons-location)))
+			 (when (binding-lended-p opt-binding)
+			   (make-lending opt-location (getf (binding-lending opt-binding)
+							    :stack-cons-location)))
+			 (when (and optp-binding (binding-lended-p optp-binding))
+			   (make-lending optp-location (getf (binding-lending optp-binding)
+							     :stack-cons-location)))))
 		      resolved-code
 		      (make-compiled-function-postlude funobj function-env
 						       use-stack-frame-p)))))