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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed some widespread confusion in the compiler about lexical function
bindings that don't borrow any lexical bindings. This caused
e.g. apropos not to work.

Date: Wed Apr 14 15:04:06 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.45 movitz/compiler.lisp:1.46
--- movitz/compiler.lisp:1.45	Wed Apr 14 10:38:14 2004
+++ movitz/compiler.lisp	Wed Apr 14 15:04:05 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.45 2004/04/14 14:38:14 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.46 2004/04/14 19:04:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2477,18 +2477,23 @@
 			      (tree-search i r))
 			    free-so-far)))
 	      ((:load-constant :load-lexical :store-lexical :init-lexvar
-		:cons-get :endp :incf-lexvar
-		:local-function-init)
+		:cons-get :endp :incf-lexvar)
+	       (assert (gethash (instruction-is i) *extended-code-expanders*))
 	       (unless (can-expand-extended-p i frame-map)
 		 (return (values nil t)))
 	       (let ((exp (expand-extended-code i funobj frame-map)))
-		 (when (tree-search exp '(:call))
+		 (when (tree-search exp '(:call :local-function-init))
 		   (return nil))
 		 (setf free-so-far
 		   (remove-if (lambda (r)
 				(or (tree-search exp r)
 				    (tree-search exp (register32-to-low8 r))))
 			      free-so-far))))
+	      ((:local-function-init)
+	       (destructuring-bind (binding)
+		   (cdr i)
+		 (unless (typep binding 'funobj-binding)
+		   (return nil))))
 	      (t (warn "Dist ~D stopped by ~A"
 		       distance i)
 		 (return nil)))))
@@ -2651,6 +2656,7 @@
 				   ((typep binding 'constant-object-binding))
 				   ((typep binding 'forwarding-binding))
 				   ((typep binding 'borrowed-binding))
+				   ((typep binding 'funobj-binding))
 				   ((and (typep binding 'fixed-required-function-argument)
 					 (plusp (or (car (gethash binding var-counts)) 0)))
 				    (prog1 nil ; may need lending-cons
@@ -3109,6 +3115,9 @@
 	 (make-load-constant (constant-object binding)
 			     result-mode
 			     funobj frame-map))
+	(funobj-binding
+	 (make-load-constant (function-binding-funobj binding)
+			     result-mode funobj frame-map))
 	(borrowed-binding
 	 (let ((slot (borrowed-binding-reference-slot binding)))
 	   (cond
@@ -3375,8 +3384,10 @@
 			     (lend-code (loop for bb in (borrowed-bindings sub-funobj)
 					    append (make-lend-lexical bb :edx nil))))
 			(cond
+			 ((typep function-binding 'funobj-binding)
+			  nil)
 			 ((null lend-code)
-			  ;; (warn "null lending")
+			  (warn "null lending")
 			  (append (make-load-constant sub-funobj :eax funobj frame-map)
 				  (make-store-lexical function-binding :eax nil frame-map)))
 			 (t (append (make-load-constant sub-funobj :eax funobj frame-map)