[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv18485

Modified Files:
	compiler.lisp 
Log Message:
The compiler used to fail upon lending of constant bindings. Fixed.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/03/16 17:47:27	1.183
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/03/16 18:03:09	1.184
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.183 2007/03/16 17:47:27 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.184 2007/03/16 18:03:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -620,43 +620,45 @@
   (check-type toplevel-funobj movitz-funobj)
   (let ((function-binding-usage ()))
     (labels ((process-binding (funobj binding usages)
-	       (if (not (eq funobj (binding-funobj binding)))
-		   (let ((borrowing-binding
-			  (or (find binding (borrowed-bindings funobj)
-				    :key #'borrowed-binding-target)
-			      (car (push (movitz-env-add-binding (funobj-env funobj)
-								 (make-instance 'borrowed-binding
-								   :name (binding-name binding)
-								   :target-binding binding))
-					 (borrowed-bindings funobj))))))
-		     ;; We don't want to borrow a forwarding-binding..
-		     (when (typep (borrowed-binding-target borrowing-binding)
-				  'forwarding-binding)
-		       (change-class (borrowed-binding-target borrowing-binding)
-				     'located-binding))
+	       (cond
+                 ((typep binding 'constant-object-binding))
+                 ((not (eq funobj (binding-funobj binding)))
+                  (let ((borrowing-binding
+                         (or (find binding (borrowed-bindings funobj)
+                              :key #'borrowed-binding-target)
+                             (car (push (movitz-env-add-binding (funobj-env funobj)
+                                                                (make-instance 'borrowed-binding
+                                                                 :name (binding-name binding)
+                                                                 :target-binding binding))
+                                        (borrowed-bindings funobj))))))
+                    ;; We don't want to borrow a forwarding-binding..
+                    (when (typep (borrowed-binding-target borrowing-binding)
+                                 'forwarding-binding)
+                      (change-class (borrowed-binding-target borrowing-binding)
+                                    'located-binding))
 ;;;		     (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S."
 ;;;			   binding (binding-env binding) funobj
 ;;;			   borrowing-binding (binding-env borrowing-binding))
 ;;;		     (pushnew borrowing-binding 
 ;;;			      (getf (binding-lended-p binding) :lended-to))
-		     (dolist (usage usages)
-		       (pushnew usage (borrowed-binding-usage borrowing-binding)))
-		     borrowing-binding)
-		 ;; Binding is local to this funobj
-		 (typecase binding
-		   (forwarding-binding
-		    (process-binding funobj (forwarding-binding-target binding) usages)
-		    #+ignore
-		    (setf (forwarding-binding-target binding)
-		      (process-binding funobj (forwarding-binding-target binding) usages)))
-		   (function-binding
-		    (dolist (usage usages)
-		      (pushnew usage
-			       (getf (sub-function-binding-usage (function-binding-parent binding))
-				     binding))
-		      (pushnew usage (getf function-binding-usage binding)))
-		    binding)
-		   (t binding))))
+                    (dolist (usage usages)
+                      (pushnew usage (borrowed-binding-usage borrowing-binding)))
+                    borrowing-binding))
+                 (t ; Binding is local to this funobj
+                  (typecase binding
+                    (forwarding-binding
+                     (process-binding funobj (forwarding-binding-target binding) usages)
+                     #+ignore
+                     (setf (forwarding-binding-target binding)
+                           (process-binding funobj (forwarding-binding-target binding) usages)))
+                    (function-binding
+                     (dolist (usage usages)
+                       (pushnew usage
+                                (getf (sub-function-binding-usage (function-binding-parent binding))
+                                      binding))
+                       (pushnew usage (getf function-binding-usage binding)))
+                     binding)
+                    (t binding)))))
 	     (resolve-sub-funobj (funobj sub-funobj)
 	       (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj)))
 		 #+ignore
@@ -6405,16 +6407,16 @@
 
 (defun ensure-local-binding (binding funobj)
   "When referencing binding in funobj, ensure we have the binding local to funobj."
-  (if (not (typep binding 'binding))
-      binding
-    (let ((target-binding (binding-target binding)))
-      (cond
-       ((eq funobj (binding-funobj target-binding))
-	binding)
-       (t (or (find target-binding (borrowed-bindings funobj)
-		    :key (lambda (binding)
-			   (borrowed-binding-target binding)))
-	      (error "Can't install non-local binding ~W." binding)))))))
+  (if (typep binding '(or (not binding) constant-object-binding))
+      binding ; Never mind if "binding" isn't a binding, or is a constant-binding.
+      (let ((target-binding (binding-target binding)))
+        (cond
+          ((eq funobj (binding-funobj target-binding))
+           binding)
+          (t (or (find target-binding (borrowed-bindings funobj)
+                  :key (lambda (binding)
+                         (borrowed-binding-target binding)))
+                 (error "Can't install non-local binding ~W." binding)))))))
 
 (defun binding-store-subtypep (binding type-specifier)
   "Is type-specifier a supertype of all values ever stored to binding?