[movitz-cvs] CVS update: movitz/special-operators-cl.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Cleaned up the way forwarding-bindings are set up, in the let compiler.

Date: Sun Feb 27 03:28:39 2005
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.45 movitz/special-operators-cl.lisp:1.46
--- movitz/special-operators-cl.lisp:1.45	Thu Feb  3 10:18:45 2005
+++ movitz/special-operators-cl.lisp	Sun Feb 27 03:28:33 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.45 2005/02/03 09:18:45 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.46 2005/02/27 02:28:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -98,7 +98,7 @@
 		    else collect
 			 (let ((binding (make-instance 'located-binding :name var)))
 			   (movitz-env-add-binding local-env binding)
-			   (compiler-values-bind (&code init-code	&functional-p functional-p
+			   (compiler-values-bind (&code init-code &functional-p functional-p
 						  &type type &returns init-register
 						  &final-form final-form)
 			       (compiler-call #'compile-form-to-register
@@ -225,12 +225,19 @@
 					 #+ignore (warn "replace ~S in ~S with outer ~S"
 							binding (binding-funobj binding)
 							(second (first init-code)))
-					 (let ((target (second (first init-code))))
+					 (compiler-values-bind (&code new-init-code &final-form target)
+					     (compiler-call #'compile-form-unprotected
+					       :form init-form
+					       :result-mode :ignore
+					       :env init-env
+					       :defaults all)
+					   (check-type target lexical-binding)
 					   (change-class binding 'forwarding-binding 
 							 :target-binding target)
-					   `((:init-lexvar ,binding
-							   :init-with-register ,target
-							   :init-with-type ,target))))
+					   (append new-init-code
+						   `((:init-lexvar ,binding
+								   :init-with-register ,target
+								   :init-with-type ,target)))))
 					((and (typep binding 'located-binding)
 					      (type-specifier-singleton type)
 					      (not (code-uses-binding-p body-code binding