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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed a bug in analyze-bindings where declared types where not taken
into account in certain situations, preventing proper type inference.

Date: Tue Aug 23 23:42:08 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.155 movitz/compiler.lisp:1.156
--- movitz/compiler.lisp:1.155	Tue Aug 23 01:05:35 2005
+++ movitz/compiler.lisp	Tue Aug 23 23:42:07 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.155 2005/08/22 23:05:35 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.156 2005/08/23 21:42:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -455,11 +455,18 @@
 			  (binding-store-type binding)))
 		  ((typep binding 'function-argument)
 		   t)
+		  ((let ((analysis (gethash binding binding-usage)))
+		     (assert (and (and analysis
+				       (null (type-analysis-thunks analysis))))
+			 (binding)
+		       "Can't resolve unresolved binding ~S." binding)))
+		  (*compiler-trust-user-type-declarations-p*
+		   (let ((analysis (gethash binding binding-usage)))
+		     (multiple-value-call #'encoded-type-decode
+		       (apply #'encoded-types-and
+			      (append (type-analysis-declared-encoded-type analysis)
+				      (type-analysis-encoded-type analysis))))))
 		  (t (let ((analysis (gethash binding binding-usage)))
-		       (assert (and (and analysis
-					 (null (type-analysis-thunks analysis))))
-			   (binding)
-			 "Can't resolve unresolved binding ~S." binding)
 		       (apply #'encoded-type-decode
 			      (type-analysis-encoded-type analysis))))))
 	       (type-is-t (type-specifier)
@@ -523,8 +530,22 @@
 					 if (not (every #'binding-resolved-p thunk-args))
 					 collect (cons thunk thunk-args)
 					 else
-					 do (setf (type-analysis-encoded-type analysis)
-					      (multiple-value-list
+					 do #+ignore
+					 (warn "because ~S=>~S->~S completing ~S: ~S and ~S"
+					       thunk thunk-args
+					       (mapcar #'binding-resolve thunk-args)
+					       binding
+					       (type-analysis-declared-encoded-type analysis)
+					       (multiple-value-list
+						(multiple-value-call
+						    #'encoded-types-or
+						  (values-list
+						   (type-analysis-encoded-type analysis))
+						  (type-specifier-encode
+						   (apply thunk (mapcar #'binding-resolve
+									thunk-args))))))
+					 (setf (type-analysis-encoded-type analysis)
+					   (multiple-value-list
 					       (multiple-value-call
 						   #'encoded-types-and
 						 (values-list
@@ -5564,6 +5585,8 @@
     #+ignore (when (and (eq result-mode :function)
 			(eq operator (movitz-print (movitz-funobj-name funobj))))
 	       (warn "Tail-recursive call detected."))
+    (when (eq operator 'muerte.cl::declare)
+      (break "Compiling funcall to ~S" 'muerte.cl::declare))
     (pushnew (cons operator muerte.cl::*compile-file-pathname*)
 	     (image-called-functions *image*)
 	     :key #'first)
@@ -6406,6 +6429,10 @@
 	(values binding init-with-type)	)
        ((and init-with-type (not (bindingp init-with-type)))
 	(values binding init-with-type))
+       ((and init-with-type
+	     (bindingp init-with-type)
+	     (binding-store-type init-with-type))
+	(apply #'encoded-type-decode (binding-store-type init-with-type)))
        (t (values binding t
 		  (lambda (x) x)
 		  (list init-with-register)))))