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

[Frode Vatvedt Fjeld]

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

Modified Files:
	special-operators.lisp 
Log Message:
Many fixes to the compiler. Basic change is that LET init-forms are
compiled with compile-form-unprotected, and that
compile-lexical-variable and compile-self-evaluating return binding
only as "returns", not in the form of "code".

Date: Sun Aug 28 23:03:55 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.53 movitz/special-operators.lisp:1.54
--- movitz/special-operators.lisp:1.53	Sat Aug 20 22:31:25 2005
+++ movitz/special-operators.lisp	Sun Aug 28 23:03:53 2005
@@ -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.53 2005/08/20 20:31:25 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.54 2005/08/28 21:03:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -82,21 +82,19 @@
      ((not (null then-forms))
       (let ((skip-label (gensym (format nil "cond-skip-~D-" clause-num))))
 	(compiler-values-bind (&code test-code)
-	    (multiple-value-bind (test-result-mode)
-		(cond
-		 ((and last-clause-p
-		       (eq (operator result-mode)
-			   :boolean-branch-on-false))
-		  (cons :boolean-branch-on-false
-			(cdr result-mode)))
-		 (t (cons :boolean-branch-on-false
-			  skip-label)))
-	      (compiler-call #'compile-form
-		:result-mode test-result-mode
-		:modify-accumulate clause-modifies
-		:form test-form
-		:funobj funobj
-		:env env))
+	    (compiler-call #'compile-form
+	      :result-mode (cond
+			    ((and last-clause-p
+				  (eq (operator result-mode)
+				      :boolean-branch-on-false))
+			     (cons :boolean-branch-on-false
+				   (cdr result-mode)))
+			    (t (cons :boolean-branch-on-false
+				     skip-label)))
+	      :modify-accumulate clause-modifies
+	      :form test-form
+	      :funobj funobj
+	      :env env)
 	  (compiler-values-bind (&code then-code &returns then-returns)
 	      (compiler-call #'compile-form
 		:form (cons 'muerte.cl::progn then-forms)
@@ -134,8 +132,7 @@
 (define-special-operator compiled-cond
     (&form form &funobj funobj &env env &result-mode result-mode)
   (let ((clauses (cdr form)))
-    (let* ((cond-modifies nil)
-	   (cond-exit-label (gensym "cond-exit-"))
+    (let* ((cond-exit-label (gensym "cond-exit-"))
 	   (cond-result-mode (case (operator result-mode)
 			       (:values :multiple-values)
 			       ((:ignore :function :multiple-values :eax :ebx :ecx :edx
@@ -152,32 +149,28 @@
 				   '(:ignore
 				     :boolean-branch-on-true
 				     :boolean-branch-on-false))))
-      (loop for clause in clauses
+      (loop with last-clause-num = (1- (length clauses))
+	  for clause in clauses
 	  for clause-num upfrom 0
-	  with last-clause-num = (1- (length clauses))
-	  as (clause-code constantly-true-p clause-modifies) =
-	    (multiple-value-list (make-compiled-cond-clause clause
-							    clause-num
-							    (and only-control-p
-								 (= clause-num last-clause-num))
-							    cond-exit-label funobj env cond-result-mode))
+	  as (clause-code constantly-true-p) =
+	    (multiple-value-list
+	     (make-compiled-cond-clause clause
+					clause-num
+					(and only-control-p
+					     (= clause-num last-clause-num))
+					cond-exit-label funobj env cond-result-mode))
 	  append clause-code into cond-code
-	  do (setf cond-modifies
-	       (modifies-union cond-modifies clause-modifies))
 	  when constantly-true-p
 	  do (return (compiler-values ()
 		       :returns cond-returns
-		       :modifies cond-modifies
 		       :code (append cond-code
 				     (list cond-exit-label))))
 	  finally
 	    (return (compiler-values ()
 		      :returns cond-returns
-		      :modifies cond-modifies
 		      :code (append cond-code
 				    ;; no test succeeded => nil
 				    (unless only-control-p
-;;;				      (warn "doing default nil..")
 				      (compiler-call #'compile-form
 					:form nil
 					:funobj funobj