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

[Frode Vatvedt Fjeld]

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