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

[Frode Vatvedt Fjeld]

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

Modified Files:
	special-operators.lisp 
Log Message:
Several changes regarding my working on some type-inference stuff in
the compiler. The only real change with this check-in is that the let
compiler special-cases the situation

 (let ((foo init-form))
    (setq bar foo))

And compiles it like (setq bar init-form).

Date: Thu Feb 12 12:54:38 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.8 movitz/special-operators.lisp:1.9
--- movitz/special-operators.lisp:1.8	Tue Feb 10 13:06:44 2004
+++ movitz/special-operators.lisp	Thu Feb 12 12:54:37 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.8 2004/02/10 18:06:44 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.9 2004/02/12 17:54:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -975,60 +975,75 @@
 		   :form term-form)
 	       (assert term2-type)
 	       (let ((term2-type (type-specifier-primary term2-type)))
+;;;		 (declare (ignore term2-type))
 ;;;		 (warn "t2-type: ~S, t2-ret: ~S, rm: ~S"
 ;;;		       term2-type term2-returns result-mode)
-		 (declare (ignore term2-type))
-		 (case term2-returns
-		   (:untagged-fixnum-eax
-		    (case result-mode
-		      (:untagged-fixnum-eax
-		       (compiler-values ()
-			 :returns :untagged-fixnum-eax
-			 :type 'integer
-			 :functional-p term2-functional-p
-			 :modifies term2-modifies
-			 :code (append term2-code
-				       `((:addl ,constant-term :eax))
-				       (unless (< #x-10000 constant-term #x10000)
-					 '((:into))))))
-		      (t (let ((result-register (accept-register-mode result-mode)))
-			   ;; (warn "XX")
-			   (compiler-values ()
-			     :returns result-register
-			     :modifies term2-modifies
-			     :functional-p term2-functional-p
-			     :code (append term2-code
-					   `((:leal ((:eax ,+movitz-fixnum-factor+)
-						     ,(* +movitz-fixnum-factor+ constant-term))
-						    ,result-register))))))))
-		   (t (multiple-value-bind (new-load-term-code add-result-mode)
-			  (make-result-and-returns-glue (accept-register-mode term2-returns)
-							term2-returns
-							term2-code)
-			(let ((add-register (single-value-register add-result-mode))
-			      (label (gensym "not-integer-")))
+		 (cond
+		  #+ignore
+		  ((and (eq 'binding-type (operator term2-type))
+			(eq (second term2-type) result-mode))
+		   (let ((binding result-mode))
+		     (check-type binding lexical-binding)
+		     (warn "yes, for ~S" binding)
+		     (compiler-values ()
+		       :returns binding
+		       :type (binding-type-specifier binding)
+		       :code (append
+			      (compiler-call #'compile-form-unprotected
+				:result-mode :ignore
+				:defaults all
+				:form term-form)
+			      `((:incf-lexvar ,binding ,constant-term))))))
+		  ((eq :untagged-fixnum-eax term2-returns)
+		   (case result-mode
+		     (:untagged-fixnum-eax
+		      (compiler-values ()
+			:returns :untagged-fixnum-eax
+			:type 'integer
+			:functional-p term2-functional-p
+			:modifies term2-modifies
+			:code (append term2-code
+				      `((:addl ,constant-term :eax))
+				      (unless (< #x-10000 constant-term #x10000)
+					'((:into))))))
+		     (t (let ((result-register (accept-register-mode result-mode)))
+			  ;; (warn "XX")
 			  (compiler-values ()
-			    :returns add-register
-			    :functional-p term2-functional-p
+			    :returns result-register
 			    :modifies term2-modifies
-			    :type 'integer
-			    :code (append
-				   new-load-term-code
-				   (unless nil
-				     #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
-							`(integer ,+movitz-most-negative-fixnum+
-								  ,+movitz-most-positive-fixnum+))
-				     `((:testb ,+movitz-fixnum-zmask+
-					       ,(register32-to-low8 add-register))
-				       (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4))))))
-				   `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register))
-				   (unless nil
-				     #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
-							`(integer ,(+ +movitz-most-negative-fixnum+
-								      constant-term)
-								  ,(+ +movitz-most-positive-fixnum+
-								      constant-term)))
-				     '((:into)))))))))))))
+			    :functional-p term2-functional-p
+			    :code (append term2-code
+					  `((:leal ((:eax ,+movitz-fixnum-factor+)
+						    ,(* +movitz-fixnum-factor+ constant-term))
+						   ,result-register))))))))
+		  (t (multiple-value-bind (new-load-term-code add-result-mode)
+			 (make-result-and-returns-glue (accept-register-mode term2-returns)
+						       term2-returns
+						       term2-code)
+		       (let ((add-register (single-value-register add-result-mode))
+			     (label (gensym "not-integer-")))
+			 (compiler-values ()
+			   :returns add-register
+			   :functional-p term2-functional-p
+			   :modifies term2-modifies
+			   :type 'integer
+			   :code (append
+				  new-load-term-code
+				  (unless nil
+				    #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
+						       `(integer ,+movitz-most-negative-fixnum+
+								 ,+movitz-most-positive-fixnum+))
+				    `((:testb ,+movitz-fixnum-zmask+
+					      ,(register32-to-low8 add-register))
+				      (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4))))))
+				  `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register))
+				  (unless nil
+				    #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
+						       `(integer ,(+ +movitz-most-negative-fixnum+
+								     constant-term)
+								 ,(+ +movitz-most-positive-fixnum+
+								     constant-term)))
+				    '((:into)))))))))))))
       (cond
        ((and (movitz-constantp term1 env)
 	     (movitz-constantp term2 env))