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)))))
