Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv2108
Modified Files:
compiler.lisp
Log Message:
Fixed nasty omission of functionality for functions with arglist like
(x &optional y). Still somewhat missing, but at least now it will
complain rather than silently produce faulty code.
Date: Thu Jun 10 05:05:56 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.66 movitz/compiler.lisp:1.67
--- movitz/compiler.lisp:1.66 Wed Jun 9 15:55:37 2004
+++ movitz/compiler.lisp Thu Jun 10 05:05:56 2004
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.66 2004/06/09 22:55:37 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.67 2004/06/10 12:05:56 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -723,6 +723,21 @@
(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-lended-p 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."))
resolved-code
(make-compiled-function-postlude funobj function-env
use-stack-frame-p)))))
@@ -798,7 +813,7 @@
(and code2 (eq x 'entry%2op))
(and code3 (eq x 'entry%3op))))
codet)))))
- ;; (warn "opt code: ~{~&~A~}" optimized-function-code)
+ ;; (print-code funobj combined-code)
(assemble-funobj funobj combined-code))))
funobj)
@@ -5839,6 +5854,8 @@
init-with-register init-with-type)
(cdr instruction)
(declare (ignore protect-carry)) ; nothing modifies carry anyway.
+ (when (string= (binding-name binding) 'reader-function)
+ (break "init: ~S" instruction))
;; (assert (eq binding (ensure-local-binding binding funobj)))
(assert (eq funobj (binding-funobj binding)))
(cond
@@ -5854,6 +5871,7 @@
(warn "Unused variable: ~S." binding)))
((typep binding 'forwarding-binding)
;; No need to do any initialization because the target will be initialized.
+ (assert (not (binding-lended-p binding)))
nil)
(t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
(warn "Variable ~S used while declared ignored." (binding-name binding)))