From ffjeld at common-lisp.net  Thu Feb  1 19:37:41 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu,  1 Feb 2007 14:37:41 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070201193741.B4E6C620C4@common-lisp.net>

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

Modified Files:
	parse.lisp 
Log Message:
Tweak decode-normal-lambda-list to also return whether &key was
present at all.


--- /project/movitz/cvsroot/movitz/parse.lisp	2006/05/05 18:37:37	1.6
+++ /project/movitz/cvsroot/movitz/parse.lisp	2007/02/01 19:37:41	1.7
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:49:17 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: parse.lisp,v 1.6 2006/05/05 18:37:37 ffjeld Exp $
+;;;; $Id: parse.lisp,v 1.7 2007/02/01 19:37:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -129,8 +129,9 @@
 (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p)
   "3.4.1 Ordinary Lambda Lists.
 Returns the requireds, &optionals, &rests, &keys, and &aux formal variables,
-a boolean signalling whether &allow-other-keys was present, and finally
-the minimum and maximum number of arguments (or nil if max is infinite)."
+a boolean signalling whether &allow-other-keys was present, and then
+the minimum and maximum number of arguments (or nil if max is infinite).
+Finally, whether &key was present or not."
   ;; Movitz extension: &edx <var> may appear first in lambda-list
   (let ((edx-var nil))
     (when (eq 'muerte::&edx (first lambda-list))
@@ -178,10 +179,10 @@
 	      (when (> (length rests) 1)
 		(error "There can only be one &REST formal parameter."))
 	      (let ((maxargs (and (null rests) ; max num. of arguments, or nil.
-				   (null keys)
-				   (not allow-other-keys-p)
-				   (+ (length requireds)
-				      (length optionals))))
+				  (null keys)
+				  (not allow-other-keys-p)
+				  (+ (length requireds)
+				     (length optionals))))
 		    (minargs (length requireds)))
 		(return (values requireds
 				optionals
@@ -199,7 +200,9 @@
 				 ((assert (not maxargs)))
 				 ((evenp (+ (length requireds) (length optionals)))
 				  :even)
-				 (t :odd))))))))))
+				 (t :odd))
+				(not (eq :missing
+					 (getf results (key) :missing)))))))))))
 
 (defun decode-optional-formal (formal)
   "3.4.1.2 Specifiers for optional parameters.



From ffjeld at common-lisp.net  Tue Feb  6 20:02:01 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue,  6 Feb 2007 15:02:01 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070206200201.CCAD87C038@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv10601

Modified Files:
	error.lisp 
Log Message:
Implement *backtrace-on-error*.


--- /project/movitz/cvsroot/movitz/losp/muerte/error.lisp	2005/04/26 23:44:36	1.4
+++ /project/movitz/cvsroot/movitz/losp/muerte/error.lisp	2007/02/06 20:02:01	1.5
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Sep  1 00:49:11 2001
 ;;;;                
-;;;; $Id: error.lisp,v 1.4 2005/04/26 23:44:36 ffjeld Exp $
+;;;; $Id: error.lisp,v 1.5 2007/02/06 20:02:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,6 +44,8 @@
      ((not *ignore-errors*)
       (let (#+ignore (*ignore-errors* t))
 	(let ((condition (signal-simple 'simple-error datum args)))
+	  (when *backtrace-on-error*
+	    (backtrace))
 	  (if condition
 	      (invoke-debugger condition)
 	    (apply 'invoke-debugger-on-designator 'simple-error datum args)))))



From ffjeld at common-lisp.net  Tue Feb  6 20:02:41 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue,  6 Feb 2007 15:02:41 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070206200241.42D334C00B@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Add allow-other-keys-symbol to run-time-context.


--- /project/movitz/cvsroot/movitz/image.lisp	2006/04/28 21:19:06	1.106
+++ /project/movitz/cvsroot/movitz/image.lisp	2007/02/06 20:02:41	1.107
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.106 2006/04/28 21:19:06 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.107 2007/02/06 20:02:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -389,6 +389,13 @@
     :map-binary-read-delayed (lambda (x type)
 			       (declare (ignore x type))
 			       (movitz-read nil)))
+   (allow-other-keys-symbol
+    :binary-type word
+    :initform :allow-other-keys
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed (lambda (x type)
+			       (declare (ignore x type))
+			       (movitz-read nil)))
    (self
     :binary-type word
     :initform 6



From ffjeld at common-lisp.net  Tue Feb  6 20:03:54 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue,  6 Feb 2007 15:03:54 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070206200354.130D07D164@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Improve slightly sxhash on longish vectors.


--- /project/movitz/cvsroot/movitz/storage-types.lisp	2006/10/27 06:53:27	1.58
+++ /project/movitz/cvsroot/movitz/storage-types.lisp	2007/02/06 20:03:53	1.59
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.58 2006/10/27 06:53:27 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.59 2007/02/06 20:03:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1008,8 +1008,10 @@
     (movitz-symbol
      (movitz-symbol-hash-key object))
     (movitz-string
-     (let ((object (movitz-print object))
-	   (result 0))
+     (let* ((object (movitz-print object))
+	    (result (if (not (> (length object) 8))
+			0
+		      (char-code (char-upcase (aref object (- (length object) 3)))))))
        (dotimes (i (min 8 (length object)))
 	 (incf result result)
 	 (incf result



From ffjeld at common-lisp.net  Tue Feb  6 20:03:58 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue,  6 Feb 2007 15:03:58 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070206200358.C3A5B7C017@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv11191

Modified Files:
	hash-tables.lisp 
Log Message:
Improve slightly sxhash on longish vectors.


--- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp	2006/04/07 21:52:36	1.12
+++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp	2007/02/06 20:03:57	1.13
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb 19 19:09:05 2001
 ;;;;                
-;;;; $Id: hash-tables.lisp,v 1.12 2006/04/07 21:52:36 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.13 2007/02/06 20:03:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -74,8 +74,12 @@
 	 , at declarations-and-body))))
 
 (defun sxhash-subvector (vector start end &optional (limit 8))
-  (let ((result 0))
-    (dotimes (i (min limit (- end start)))
+  (let* ((length (- end start))
+	 (result (if (not (> length 8))
+		     0
+		   (sxhash-limited (aref vector (- end 3))
+				   1))))
+    (dotimes (i (min limit length))
       (incf result result)
       (incf result
 	    (let* ((element (aref vector (+ start i)))
@@ -84,7 +88,7 @@
 		  element-hash
 		(* 7 element-hash)))))
     (ldb (byte 16 0)
-	 (+ (* #x10ad (- end start))
+	 (+ (* #x10ad length)
 	    result))))
 
 (defun sxhash-limited (object limit)



From ffjeld at common-lisp.net  Sun Feb 11 21:57:14 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 11 Feb 2007 16:57:14 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070211215714.727FA1A09C@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv20872

Modified Files:
	format.lisp 
Log Message:
Fix format for "~@{ .. ~^ .. ~}" which used to be flawed.


--- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp	2006/11/07 12:16:59	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp	2007/02/11 21:57:14	1.15
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.14 2006/11/07 12:16:59 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.15 2007/02/11 21:57:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -284,17 +284,19 @@
 			     (setf args loop-args))
 			  skip-iteration))
 			(at-sign-p
-			 (if (or (zerop loop-limit)
-				 (null args))
-			     (setf i (skip-iteration control-string (1+ i)))
-			   (multiple-value-setq (i args)
-			     (format-by-string control-string (1+ i) (1- loop-limit) args))))
+			 (unless (or (zerop loop-limit)
+				     (null args))
+			   (setf args (nth-value 1 (format-by-string control-string (1+ i)
+								     (1- loop-limit) args))))
+			 (setf i (skip-iteration control-string (1+ i))))
 			(t (let ((loop-args (pop args)))
 			     (unless (or (zerop loop-limit) (null loop-args))
 			       (format-by-string control-string (1+ i)
 						 (1- loop-limit) loop-args))
 			     (setf i (skip-iteration control-string (1+ i)))))))))
-	      (#\} (if (and args (or (not loop-limit) (not (zerop loop-limit))))
+	      (#\} (if (and args
+			    (or (not loop-limit)
+				(not (zerop loop-limit))))
 		       (setf loop-limit (and loop-limit (1- loop-limit))
 			     i (1- start))
 		     (go end-loop)))



From ffjeld at common-lisp.net  Thu Feb 15 22:00:59 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 15 Feb 2007 17:00:59 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070215220059.2A22134020@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Working on improving &key parsing.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2006/05/26 18:39:48	1.171
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/15 22:00:58	1.172
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.171 2006/05/26 18:39:48 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.172 2007/02/15 22:00:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -786,17 +786,16 @@
 		  "Jumper-set ~S multiply defined." name)
 		(setf (getf all-jumper-sets name) set))
       finally
-	(multiple-value-bind (const-list num-jumpers jumpers-map)
+	(multiple-value-bind (const-list num-jumpers jumpers-map borrower-map)
 	    (layout-funobj-vector all-constants-plist
 				  all-key-args-constants
 				  all-jumper-sets
-				  (length (borrowed-bindings funobj)))
+				  (borrowed-bindings funobj))
 	  (setf (movitz-funobj-num-jumpers funobj) num-jumpers
 		(movitz-funobj-const-list funobj) const-list
 		(movitz-funobj-num-constants funobj) (length const-list)
 		(movitz-funobj-jumpers-map funobj) jumpers-map)
-	  (loop for binding in (borrowed-bindings funobj)
-	      as pos upfrom num-jumpers
+	  (loop for (binding . pos) in borrower-map
 	      do (setf (borrowed-binding-reference-slot binding) pos))
 	  (return funobj))))
     
@@ -1670,7 +1669,8 @@
 	 (simple-instruction-p (c)
 	   (let ((c (ignore-instruction-prefixes c)))
 	     (and (listp c)
-		  (member (car c) '(:movl :xorl :popl :cmpl :leal :andl :addl :subl)))))
+		  (member (car c)
+			  '(:movl :xorl :popl :pushl :cmpl :leal :andl :addl :subl)))))
 	 (register-indirect-operand (op base)
 	   (multiple-value-bind (reg off)
 	       (when (listp op)
@@ -1711,6 +1711,9 @@
 	 (preserves-register-p (i register)
 	   (let ((i (ignore-instruction-prefixes i)))
 	     (and (not (atom i))
+		  (not (and (eq register :esp)
+			    (member (instruction-is i)
+				    '(:pushl :popl))))
 		  (or (and (simple-instruction-p i)
 			   (not (eq register (idst i))))
 		      (instruction-is i :frame-map)
@@ -1748,10 +1751,9 @@
 	   (and x (dolist (y more t)
 		    (unless (equal x y)
 		      (return nil)))))
-	 #+ignore
 	 (uses-stack-frame-p (c)
 	   (and (consp c)
-		(some #'stack-frame-operand (cdr c))))
+		(some #'stack-frame-operand (cdr (ignore-instruction-prefixes c)))))
 	 (load-stack-frame-p (c &optional (op :movl))
 	   (stack-frame-operand (twop-src c op)))
 	 (store-stack-frame-p (c &optional (op :movl))
@@ -2101,25 +2103,26 @@
 		      ((flet ((try (place register &optional map reason)
 				"See if we can remove a stack-frame load below current pc,
                               given the knowledge that <register> is equal to <place>."
-				(let ((next-load (and place
-						      (dolist (si (cdr pc))
-							(when (and (twop-p si :cmpl)
-								   (equal place (twop-src si)))
-							  (warn "Reverse cmp not yet dealed with.."))
-							(cond
-							 ((and (twop-p si :cmpl)
-							       (equal place (twop-dst si)))
-							  (return si))
-							 ((equal place (local-load-p si))
-							  (return si))
-							 ((or (not (consp si))
-							      (not (preserves-register-p si register))
-							      (equal place (twop-dst si)))
-							  (return nil)))
-							(setf map
-							  (remove-if (lambda (m)
-								       (not (preserves-register-p si (cdr m))))
-								     map))))))
+				(let ((next-load
+				       (and place
+					    (dolist (si (cdr pc))
+					      (when (and (twop-p si :cmpl)
+							 (equal place (twop-src si)))
+						(warn "Reverse cmp not yet dealed with.."))
+					      (cond
+					       ((and (twop-p si :cmpl)
+						     (equal place (twop-dst si)))
+						(return si))
+					       ((equal place (local-load-p si))
+						(return si))
+					       ((or (not (consp si))
+						    (not (preserves-register-p si register))
+						    (equal place (twop-dst si)))
+						(return nil)))
+					      (setf map
+						(remove-if (lambda (m)
+							     (not (preserves-register-p si (cdr m))))
+							   map))))))
 				  (case (instruction-is next-load)
 				    (:movl
 				     (let ((pos (position next-load pc)))
@@ -2197,6 +2200,33 @@
 			     next-pc (nthcdr 3 pc))
 		       (explain nil "Removed redundant store before ~A: ~A"
 				i2 (subseq pc 0 3)))
+		      #+ignore
+		      ((let ((stack-pos (store-stack-frame-p i))) 
+			 (and stack-pos
+			      (loop with search-pc = (cdr pc)
+				  while search-pc
+				  repeat 10
+				  for ii = (pop search-pc)
+				  thereis (eql stack-pos 
+					       (store-stack-frame-p ii))
+				  while (or (global-funcall-p ii)
+					    (and (simple-instruction-p ii)
+						 (not (eql stack-pos
+							   (uses-stack-frame-p ii))))))
+			      #+ignore
+			      (eql stack-pos 
+				   (store-stack-frame-p i4))
+			      #+ignore
+			      (every (lambda (ii)
+				       (or (global-funcall-p ii)
+					   (and (simple-instruction-p ii)
+						(not (eql stack-pos
+							  (uses-stack-frame-p ii))))))
+				     (list i2 i3))))
+		       (setf p nil
+			     next-pc (cdr pc))
+		       (explain t "removing redundant store at ~A"
+				(subseq pc 0 (min 10 (length pc)))))
 		      ((and (member (instruction-is i)
 				    '(:cmpl :cmpb :cmpw :testl :testb :testw))
 			    (member (instruction-is i2)
@@ -2629,7 +2659,49 @@
   (and (assoc binding map) t))
 
 (defun frame-map-size (map)
-  (reduce #'max map :initial-value 0 :key (lambda (x) (if (integerp (cdr x)) (cdr x) 0))))
+  (reduce #'max map
+	  :initial-value 0
+	  :key (lambda (x)
+		 (if (integerp (cdr x))
+		     (cdr x)
+		   0))))
+
+(defun frame-map-next-free-location (frame-map env &optional (size 1))
+  (labels ((stack-location (binding)
+	     (if (typep binding 'forwarding-binding)
+		 (stack-location (forwarding-binding-target binding))
+	       (new-binding-location binding frame-map :default nil)))
+	   (env-extant (env1 env2)
+	     "Is env1 active whenever env2 is active?"
+	     (cond
+	      ((null env2)
+	       nil)
+	      ((eq env1 env2)
+	       ;; (warn "~S shadowed by ~S" env env2)
+	       t)
+	      (t (env-extant env1 (movitz-environment-extent-uplink env2))))))
+    (let ((frame-size (frame-map-size frame-map)))
+      (or (loop for location from 1 to frame-size
+	      when
+		(loop for sub-location from location below (+ location size)
+		    never
+		      (find-if (lambda (b-loc)
+				 (destructuring-bind (binding . binding-location)
+				     b-loc
+				   (or (and (not (bindingp binding))
+					    (eql sub-location binding-location))
+				       (and (eql sub-location (stack-location binding))
+					    (labels
+						((z (b)
+						   (when b
+						     (or (env-extant (binding-env b) env)
+							 (env-extant env (binding-env b))
+							 (when (typep b 'forwarding-binding)
+							   (z (forwarding-binding-target b)))))))
+					      (z binding))))))
+			       frame-map))
+	      return location)
+	  (1+ frame-size)))))		; no free location found, so grow frame-size.
 
 (define-setf-expander new-binding-location (binding map-place &environment env)
   (multiple-value-bind (temps values stores setter getter)
@@ -2772,7 +2844,7 @@
 	  finally
 	    (return (values non-key-constants jumper-sets key-args-constants))))))
 
-(defun layout-funobj-vector (constants key-args-constants jumper-sets num-borrowing-slots)
+(defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings)
   (let* ((jumpers (loop with x
 		      for set in (cdr jumper-sets) by #'cddr
 		      unless (search set x)
@@ -2780,7 +2852,8 @@
 		      finally (return x)))
 	 (num-jumpers (length jumpers)))
     (values (append jumpers
-		    (make-list num-borrowing-slots :initial-element *movitz-nil*)
+		    (make-list (length borrowing-bindings)
+			       :initial-element *movitz-nil*)
 		    (mapcar (lambda (x) (movitz-read (car x)))
 			    (append (sort (loop for (constant count) on constants by #'cddr
 					      unless (or (eq constant *movitz-nil*)
@@ -2790,7 +2863,10 @@
 				    key-args-constants)))
 	    num-jumpers
 	    (loop for (name set) on jumper-sets by #'cddr
-		collect (cons name set)))))
+		collect (cons name set))
+	    (loop for borrowing-binding in borrowing-bindings
+		as pos upfrom num-jumpers
+		collect (cons borrowing-binding pos)))))
 
 (defun movitz-funobj-intern-constant (funobj obj)
   ;; (error "XXXXX")
@@ -3090,218 +3166,210 @@
   (check-type function-env function-env)
   (assert (= initial-stack-frame-position
 	     (1+ (frame-map-size frame-map))))
-  (let* ((env-roof-map nil)		; memoize result of assign-env-bindings
+  (let* ((env-assigned-p nil)		; memoize result of assign-env-bindings
 	 (flat-program code)
 	 (var-counts (discover-variables flat-program function-env)))
     (labels
-	((env-floor (env)
-	   (cond
-	    ((eq env function-env)
-	     initial-stack-frame-position)
-	    ((typep env 'function-env)
-	     (error "SEFEW: ~S" function-env))
-	    ;; The floor of this env is the roof of its extent-uplink.
-	    (t (assign-env-bindings (movitz-environment-extent-uplink env)))))
-	 ;; PROMOTE FORW-BINDINGS TO UPPER ENV!!
-	 (assign-env-bindings (env)
-	   (or (getf env-roof-map env nil)
-	       (let* ((stack-frame-position (env-floor env))
-		      (bindings-to-locate
-		       (loop for binding being the hash-keys of var-counts
-			   when
-			     (and (eq env (binding-extent-env binding))
-				  (not (let ((variable (binding-name binding)))
-					 (cond
-					  ((not (typep binding 'lexical-binding)))
-					  ((typep binding 'lambda-binding))
-					  ((typep binding 'constant-object-binding))
-					  ((typep binding 'forwarding-binding)
-					   ;; Immediately "assign" to target.
-					   (when (plusp (or (car (gethash binding var-counts)) 0))
-					     (setf (new-binding-location binding frame-map)
-					       (forwarding-binding-target binding)))
-					   t)
-					  ((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
-					     (setf (new-binding-location binding frame-map)
-					       `(:argument-stack ,(function-argument-argnum binding)))))
-					  ((unless (or (movitz-env-get variable 'ignore nil
-								       (binding-env binding) nil)
-						       (movitz-env-get variable 'ignorable nil
-								       (binding-env binding) nil)
-						       (typep binding 'hidden-rest-function-argument)
-						       (third (gethash binding var-counts)))
-					     (warn "Unused variable: ~S"
-						   (binding-name binding))))
-					  ((not (plusp (or (car (gethash binding var-counts)) 0))))))))
-			   collect binding))
-		      (bindings-fun-arg-sorted
-		       (when (eq env function-env)
-			 (sort (copy-list bindings-to-locate) #'<
-			       :key (lambda (binding)
-				      (etypecase binding
-					(edx-function-argument 3)
-					(positional-function-argument
-					 (* 2 (function-argument-argnum binding)))
-					(binding 100000))))))
-		      (bindings-register-goodness-sort
+	((assign-env-bindings (env)
+	   (unless (member env env-assigned-p)
+	     (unless (eq env function-env)
+	       (assign-env-bindings (movitz-environment-extent-uplink env)))
+	     (let* ((bindings-to-locate
+		     (loop for binding being the hash-keys of var-counts
+			 when
+			   (and (eq env (binding-extent-env binding))
+				(not (let ((variable (binding-name binding)))
+				       (cond
+					((not (typep binding 'lexical-binding)))
+					((typep binding 'lambda-binding))
+					((typep binding 'constant-object-binding))
+					((typep binding 'forwarding-binding)
+					 (when (plusp (or (car (gethash binding var-counts)) 0))
+					   (assert (new-binding-located-p binding frame-map)))
+					 t)
+					((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
+					   (setf (new-binding-location binding frame-map)
+					     `(:argument-stack ,(function-argument-argnum binding)))))
+					((unless (or (movitz-env-get variable 'ignore nil
+								     (binding-env binding) nil)
+						     (movitz-env-get variable 'ignorable nil
+								     (binding-env binding) nil)
+						     (typep binding 'hidden-rest-function-argument)
+						     (third (gethash binding var-counts)))
+					   (warn "Unused variable: ~S"
+						 (binding-name binding))))
+					((not (plusp (or (car (gethash binding var-counts)) 0))))))))
+			 collect binding))
+		    (bindings-fun-arg-sorted
+		     (when (eq env function-env)
 		       (sort (copy-list bindings-to-locate) #'<
-			     ;; Sort so as to make the most likely
-			     ;; candidates for locating to registers
-			     ;; be assigned first (i.e. maps to
-			     ;; a smaller value).
-			     :key (lambda (b)
-				    (etypecase b
-				      ((or constant-object-binding
-					forwarding-binding
-					borrowed-binding)
-				       1000)
-				      (fixed-required-function-argument
-				       (+ 100 (function-argument-argnum b)))
-				      (located-binding
-				       (let* ((count-init (gethash b var-counts))
-					      (count (car count-init))
-					      (init-pc (second count-init)))
-					 (if (not (and count init-pc))
-					     50
-					   (truncate
-					    (or (position-if (lambda (i)
-							       (member b (find-read-bindings i)))
-							     (cdr init-pc))
-						15)
-					    count)))))))))
-		 #+ignore (labels ((dox (env upper)
-				     (if (or (not env)
-					     (not (sub-env-p env function-env)))
-					 0
-				       (let ((level (dox (funcall upper env) upper)))
-					 (format t "~%~v{ ~}~S" level t env)
-					 (+ level 4)))))
-			    (warn "At ~S binding ~S:~{ ~S~}: Extent: ~A~%Bind: ~A" 
-				  stack-frame-position
-				  env bindings-to-locate
-				  (with-output-to-string (*standard-output*)
-				    (dox env #'movitz-environment-extent-uplink))
-				  (with-output-to-string (*standard-output*)
-				    (when bindings-to-locate
-				      (dox (binding-env (first bindings-to-locate))
-					   #'movitz-environment-uplink)))))
-		 #+ignore
-		 (loop for binding in bindings-to-locate
-		     do (when (binding-store-type binding)
-			  (warn "~S => ~S" binding (binding-store-type binding)))
-			(when (typep (binding-store-type binding) 'lexical-binding)
-			  (warn "binding ~S == ~S"
-				binding (binding-store-type binding))))
-		 ;; First, make several passes while trying to locate bindings
-		 ;; into registers.
-		 (loop repeat 100 with try-again = t and did-assign = t
-		     do (unless (and try-again did-assign)
-			  (return))
-		     do (setf try-again nil did-assign nil)
-			(loop for binding in bindings-fun-arg-sorted
-			    while (or (typep binding 'register-required-function-argument)
-				      (typep binding 'floating-required-function-argument)
-				      (and (typep binding 'positional-function-argument)
-					   (< (function-argument-argnum binding)
-					      2)))
-			    do (unless (new-binding-located-p binding frame-map)
-				 (multiple-value-bind (register status)
-				     (try-locate-in-register binding var-counts
-							     (movitz-environment-funobj function-env)
-							     frame-map)
-				   (cond
-				    (register
-				     (setf (new-binding-location binding frame-map)
-				       register)
-				     (setf did-assign t))
-				    ((eq status :not-now)
-				     ;; (warn "Wait for ~S map ~A" binding frame-map)
-				     (setf try-again t))
-				    (t (assert (eq status :never)))))))
-			(dolist (binding bindings-register-goodness-sort)

[1005 lines skipped]



From ffjeld at common-lisp.net  Thu Feb 15 22:01:02 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 15 Feb 2007 17:01:02 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070215220102.6907834020@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Working on improving &key parsing.


--- /project/movitz/cvsroot/movitz/environment.lisp	2006/05/07 18:34:30	1.17
+++ /project/movitz/cvsroot/movitz/environment.lisp	2007/02/15 22:01:02	1.18
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.17 2006/05/07 18:34:30 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.18 2007/02/15 22:01:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -191,6 +191,9 @@
     :accessor oddeven-args)
    (allow-other-keys-p
     :accessor allow-other-keys-p)
+   (allow-other-keys-var
+    :initform nil
+    :accessor allow-other-keys-var)
    (edx-var
     :initform nil
     :accessor edx-var)
@@ -206,6 +209,11 @@
    (key-vars
     :initform nil
     :accessor key-vars)
+   (key-decode-map
+    :initform nil
+    :accessor key-decode-map)
+   (key-decode-shift
+    :accessor key-decode-shift)
    (need-normalized-ecx-p
     :initarg :need-normalized-ecx-p
     :accessor need-normalized-ecx-p)



From ffjeld at common-lisp.net  Fri Feb 16 20:17:23 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 16 Feb 2007 15:17:23 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070216201723.BC95233083@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Removed some deprecated code.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/15 22:00:58	1.172
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/16 20:17:23	1.173
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.172 2007/02/15 22:00:58 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.173 2007/02/16 20:17:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3489,66 +3489,6 @@
 are load-lexicals of the first two function arguments, and if possible these
 bindings are located in the appropriate register, so no stack location is needed."
   (check-type env function-env)
-  #+ignore
-  (let ((funobj (movitz-environment-funobj env))
-	(scan-code code))
-    ;; (warn "code: ~{~&~S~}" (subseq scan-code 0 5))
-    (let ((first-location
-	   (multiple-value-bind (first-load-binding first-load-destination)
-	       (instruction-is-load-lexical-of-binding (first scan-code))
-	     (when (and *compiler-allow-transients*
-			first-load-binding
-			(eq funobj (movitz-environment-funobj (binding-env first-load-binding)))
-			(not (code-uses-binding-p (rest scan-code) first-load-binding
-						  :load t :store t :call t)))
-	       (let* ((location (case (result-mode-type first-load-destination)
-				  ((:push :boolean-branch-on-false :boolean-branch-on-true)
-				   (case (if (typep first-load-binding 'positional-function-argument)
-					     (function-argument-argnum first-load-binding)
-					   0)
-				     (0 :eax)
-				     (1 :ebx)))
-				  ((:eax :single-value :function :ecx :edx) :eax)
-				  (:ebx :ebx)
-				  (t :eax))))
-		 ;; (warn "loc: ~W, bind: ~S" location first-load-binding)
-		 (when location
-		   (when (typep first-load-binding 'register-required-function-argument)
-		     ;; (warn "assigning ~W to ~W:~{~&   ~A~}" first-load-binding location (subseq code 0 12))
-		     ;; (setf (binding-location first-load-binding) location)
-		     (setf (new-binding-location first-load-binding frame-map) location)
-		     (setf scan-code (rest scan-code))))
-		 location)))))
-      (multiple-value-bind (first-load-binding first-load-destination)
-	  (instruction-is-load-lexical-of-binding (first scan-code))
-	(when (and *compiler-allow-transients*
-		   first-load-binding
-		   (eq funobj (movitz-environment-funobj (binding-env first-load-binding)))
-		   (not (code-uses-binding-p (rest scan-code) first-load-binding
-					     :load t :store t :call t)))
-	  (let* ((location (case first-load-destination
-			     ((:push :boolean-branch-on-true :boolean-branch-on-false)
-			      (case (if (typep first-load-binding 'positional-function-argument)
-					(function-argument-argnum first-load-binding)
-				      1)
-				(0 :eax)
-				(1 :ebx)))
-			     ((:eax :single-value :function) :eax)
-			     (:ebx :ebx))))
-	    ;;(warn "loc2: ~W, bind2: ~S" location first-load-binding)
-	    (when location
-	      ;; (warn "assigning ~W to ~W.." first-load-binding location)
-	      ;; (warn "assigning ~W to ~W:~{~&   ~A~}" first-load-binding location (subseq code 0 12))
-	      (when (eq location first-location)
-		(setf location (ecase first-location
-				 (:eax :ebx)
-				 (:ebx :eax))))
-	      (when (typep first-load-binding 'register-required-function-argument)
-		;; (setf (binding-location first-load-binding) location)
-		(setf (new-binding-location first-load-binding frame-map) location)
-		(setf scan-code (rest scan-code)))))))))
-  #+ignore
-  (assign-bindings code env stack-frame-position frame-map)
   (assign-bindings (append (when (first (required-vars env))
 			     (let ((binding (movitz-binding (first (required-vars env))
 							    env nil)))



From ffjeld at common-lisp.net  Sat Feb 17 19:24:28 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Sat, 17 Feb 2007 14:24:28 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070217192428.F37B55C000@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Minor cleanup of make-function-arguments-init.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/16 20:17:23	1.173
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/17 19:24:28	1.174
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.173 2007/02/16 20:17:23 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.174 2007/02/17 19:24:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2850,22 +2850,24 @@
 		      unless (search set x)
 		      do (setf x (nconc x (copy-list set)))
 		      finally (return x)))
-	 (num-jumpers (length jumpers)))
+	 (num-jumpers (length jumpers))
+	 (stuff (append key-args-constants
+			(sort (loop for (constant count) on constants by #'cddr
+				  unless (or (eq constant *movitz-nil*)
+					     (eq constant (image-t-symbol *image*)))
+				  collect (cons constant count))
+			      #'< :key #'cdr))))
     (values (append jumpers
+		    (mapcar (lambda (x)
+			      (movitz-read (car x)))
+			    stuff)
 		    (make-list (length borrowing-bindings)
-			       :initial-element *movitz-nil*)
-		    (mapcar (lambda (x) (movitz-read (car x)))
-			    (append (sort (loop for (constant count) on constants by #'cddr
-					      unless (or (eq constant *movitz-nil*)
-							 (eq constant (image-t-symbol *image*)))
-					      collect (cons constant count))
-					  #'< :key #'cdr)
-				    key-args-constants)))
+			       :initial-element *movitz-nil*))
 	    num-jumpers
 	    (loop for (name set) on jumper-sets by #'cddr
 		collect (cons name set))
 	    (loop for borrowing-binding in borrowing-bindings
-		as pos upfrom num-jumpers
+		as pos upfrom (+ num-jumpers (length stuff))
 		collect (cons borrowing-binding pos)))))
 
 (defun movitz-funobj-intern-constant (funobj obj)
@@ -4783,8 +4785,7 @@
 	 (movitz-binding (decode-keyword-formal (first key-vars)) env))))
     (values
      (append
-      (loop ;;  with eax-optional-destructive-p = nil
-	  for optional in optional-vars
+      (loop for optional in optional-vars
 	  as optional-var = (decode-optional-formal optional)
 	  as binding = (movitz-binding optional-var env)
 	  as last-optional-p = (and (null key-vars)
@@ -4966,22 +4967,12 @@
 			    :result-mode :ebx)
 			  `((:jmp 'default-done)))))
 		,@(case position
-		    (0 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :eax :op :cmpl))
-		       #+ignore `((:cmpl (:esi ,(movitz-funobj-intern-constant
-						 funobj
-						 (movitz-read (keyword-function-argument-keyword-name binding))))
-					 :eax)))
-		    (1 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :ebx :op :cmpl))
-		       #+ignore `((:cmpl (:esi ,(movitz-funobj-intern-constant
-						 funobj
-						 (movitz-read (keyword-function-argument-keyword-name binding))))
-					 :ebx)))
-		    (t `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :eax :op :cmpl))
-		       #+ignore `((:movl (:ebp (:ecx 4) ,(* -4 (1- position))) :eax)
-				  (:cmpl (:esi ,(movitz-funobj-intern-constant
-						 funobj
-						 (movitz-read (keyword-function-argument-keyword-name binding))))
-					 :eax))))
+		    (0 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
+					 :eax :op :cmpl)))
+		    (1 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
+					 :ebx :op :cmpl)))
+		    (t `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
+					 :eax :op :cmpl))))
 		,@(if allow-other-keys-p
 		      `((:jne 'default))
 		    `((:jne '(:sub-program (unknown-key) (:int 101)))))



From ffjeld at common-lisp.net  Sun Feb 18 14:52:24 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 18 Feb 2007 09:52:24 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070218145224.77A373F002@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv17716

Modified Files:
	primitive-functions.lisp 
Log Message:
Wrote primitive function decode-keyargs-default for new &key parsing implementation.


--- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2005/05/05 20:51:43	1.65
+++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/18 14:52:24	1.66
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.65 2005/05/05 20:51:43 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.66 2007/02/18 14:52:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -734,3 +734,109 @@
     (:jnz 'copy-jumpers)
     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
     (:ret)))
+
+
+(define-primitive-function decode-keyargs-default ()
+  "Decode keyword arguments."
+  (with-inline-assembly (:returns :multiple-values)
+    ;; EAX: arg0 (if needed)
+    ;; EBX: arg1 (if needed)
+    ;; ECX: numargs (fixnum)
+    ;; EDX: arg-position of first keyword (fixnum)
+
+    (:subl :edx :ecx)			; find stop-pos
+    (:jbe '(:sub-program (no-key-args)
+	    (:ret)))
+
+    (:locally (:movl #xffffffff (:edi (:edi-offset scratch1)))) ; unbond-value
+    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2)))) ; unbond-value
+    (:cmpl 4 :edx)			; keys start at 0 or 1?
+    (:jbe '(:sub-program (save-eax-ebx)
+	    (:je 'save-ebx-only)
+	    (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+	    save-ebx-only
+	    (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
+	    (:subl 8 :ecx)
+	    (:jmp 'continue-save-eax-ebx)))
+   continue-save-eax-ebx
+    (:testl 4 :ecx)
+    (:jnz '(:sub-program (odd-keywords)
+	    (:orl 32 (:ebp -16))
+	    (:andl -8 :ecx)
+	    (:jmp 'continue-from-odd-keywords)))
+   continue-from-odd-keywords
+    (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos
+    (:xorl :edx :edx)			; EDX scans the args, last-to-first.
+
+    (:cmpl :edx :ecx)			; might occur if key-arg-pos is 0 or 1,
+    (:jbe 'check-arg0-arg1)		; and numargs is 2 or 3.
+    
+   scan-args-loop
+    ;; Load current argument keyword and value into EAX and EBX
+    (:movl (:ebp :edx 12) :eax)
+    (:movl (:ebp :edx 8) :ebx)
+    
+   start-keyword-search
+    ;; EAX: (presumed) keyword, EBX corresponding value.
+    (:globally (:cmpl :eax (:edi (:edi-offset allow-other-keys-symbol))))
+    (:je '(:sub-program (found-allow-other-keys)
+	   ;; store boolean EBX in bit 2 of (ebx -16).
+	   (:andl -8 (:ebp -16))
+	   (:cmpl :edi :ebx)
+	   (:je 'finished-keyword-search)
+	   (:orl 4 (:ebp -16))		; Signal :allow-other-keys t
+	   (:jmp 'finished-keyword-search)))
+    (:leal (:eax -5) :ecx)
+    (:testb 5 :cl)
+    (:jnz '(:sub-program (keyword-not-symbol)
+	    (:orl 16 (:ebp -16))	; Signal keyword-not-symbol
+	    (:jmp 'finished-keyword-search)))
+    (:movl (:esi (:offset movitz-funobj num-jumpers))
+	   :ecx)
+    (:andl #xfffc :ecx)
+   position-search-loop
+    ;; ECX scans funobj's keyword vector for position of keyword in EAX
+    (:cmpl :eax (:esi :ecx (:offset movitz-funobj constant0)))
+    (:je 'found-keyword)
+    (:testb 1 (:esi :ecx (:offset movitz-funobj constant0)))
+    (:jz '(:sub-program (keyword-not-fund)
+	   (:orl 8 (:ebp -16))		; signal unknown-keyword
+	   (:jmp 'finished-keyword-search)))
+    (:addl 4 :ecx)
+    (:jmp 'position-search-loop)
+    
+   found-keyword
+    (:subw (:esi (:offset movitz-funobj num-jumpers)) :cx)
+    (:negl :ecx)
+    (:movl :ebx (:ebp -20 (:ecx 2)))
+    (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx))
+    (:movl :ebx (:ebp -20 (:ecx 2) -4))
+    
+   finished-keyword-search
+    (:addl 8 :edx)
+    (:locally (:cmpl :edx (:edi (:edi-offset raw-scratch0)))) ; more args?
+    (:ja 'scan-args-loop)
+
+   check-arg0-arg1
+    (:locally (:cmpl -1 (:edi (:edi-offset scratch1))))
+    (:jne '(:sub-program (search-eax-ebx)
+	    ;; Search one more keyword, in arg0 and arg1
+	    (:locally (:movl (:edi (:edi-offset scratch1)) :eax))
+	    (:locally (:movl (:edi (:edi-offset scratch2)) :ebx))
+	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch1))))
+	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2))))
+	    (:jmp 'start-keyword-search)))
+    (:locally (:cmpl -1 (:edi (:edi-offset scratch2))))
+    (:jne '(:sub-program (search-ebx)
+	    ;; Search one more keyword, in arg1 and last on-stack.
+	    (:locally (:movl (:edi (:edi-offset scratch2)) :eax))
+	    (:movl (:ebp :edx 8) :ebx)	    
+	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2))))
+	    (:jmp 'start-keyword-search)))
+    (:ret)))
+
+(define-primitive-function decode-keyargs-foo ()
+  "foo"
+  (with-inline-assembly (:returns :multiple-values)
+    (:ret)))
+



From ffjeld at common-lisp.net  Sun Feb 18 14:53:07 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 18 Feb 2007 09:53:07 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070218145307.E61C349032@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Add primitive function decode-keyargs-default to
run-time-context. Also, do some GC tweaking on #+allegro.


--- /project/movitz/cvsroot/movitz/image.lisp	2007/02/06 20:02:41	1.107
+++ /project/movitz/cvsroot/movitz/image.lisp	2007/02/18 14:53:07	1.108
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.107 2007/02/06 20:02:41 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.108 2007/02/18 14:53:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -112,6 +112,22 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
+
+   (keyword-search
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function
+    :binary-type code-vector-word)
+   (decode-keyargs-default
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function
+    :binary-type code-vector-word)
+   (decode-keyargs-foo
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function
+    :binary-type code-vector-word)
    
    (fast-car
     :binary-type code-vector-word
@@ -195,11 +211,6 @@
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
-   (keyword-search
-    :map-binary-write 'movitz-intern-code-vector
-    :map-binary-read-delayed 'movitz-word-code-vector
-    :binary-tag :primitive-function
-    :binary-type code-vector-word)
    (box-u32-ecx
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
@@ -804,6 +815,7 @@
 
 (defun create-image (&rest init-args
 		     &key (init-file *default-image-init-file*)
+			  (gc t)
 			  ;; (start-address #x100000)
 			  &allow-other-keys)
   (psetq *image* (let ((*image* (apply #'make-movitz-image
@@ -813,6 +825,10 @@
 		     (movitz-compile-file init-file))
 		   *image*)
 	 *i* (when (boundp '*image*) *image*))
+  (when gc
+    #+allegro (setf (sys:gsgc-parameter :generation-spread) 8)
+    #+allegro (excl:gc :tenure)
+    #+allegro (excl:gc t))		; We just thrashed a lot of tenured objects.
   *image*)
 
 (defun set-file-position (stream position &optional who)



From ffjeld at common-lisp.net  Sun Feb 18 16:31:42 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 18 Feb 2007 11:31:42 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070218163142.38F3E48151@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv358

Modified Files:
	primitive-functions.lisp 
Log Message:
Improved decode-keyargs-default.


--- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/18 14:52:24	1.66
+++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/18 16:31:42	1.67
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.66 2007/02/18 14:52:24 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.67 2007/02/18 16:31:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -737,33 +737,34 @@
 
 
 (define-primitive-function decode-keyargs-default ()
-  "Decode keyword arguments."
+  "Decode keyword arguments. Results are placed in stack-frame,
+starting at (:ebp -16)."
   (with-inline-assembly (:returns :multiple-values)
-    ;; EAX: arg0 (if needed)
-    ;; EBX: arg1 (if needed)
     ;; ECX: numargs (fixnum)
     ;; EDX: arg-position of first keyword (fixnum)
+    ;; (:ebp  -8) arg0 (if needed)
+    ;; (:ebp -12) arg1 (if needed)
 
     (:subl :edx :ecx)			; find stop-pos
     (:jbe '(:sub-program (no-key-args)
 	    (:ret)))
 
-    (:locally (:movl #xffffffff (:edi (:edi-offset scratch1)))) ; unbond-value
-    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2)))) ; unbond-value
+    (:locally (:movl :edx (:edi (:edi-offset scratch1)))) ; first-key-position
+    ;; Error flags (0 = "not occurred", 1 = "occurred"):
+    ;;   #x04: Unknown keyword.
+    ;;   #x08: Keyword not a symbol.
+    ;;   #x10: Odd number of keyword-args.
+    ;;   #x20: :allow-other-keys (0 = nil, 1 = t).
+    (:locally (:movl #x0 (:edi (:edi-offset scratch2)))) ; initial error flags
     (:cmpl 4 :edx)			; keys start at 0 or 1?
     (:jbe '(:sub-program (save-eax-ebx)
-	    (:je 'save-ebx-only)
-	    (:locally (:movl :eax (:edi (:edi-offset scratch1))))
-	    save-ebx-only
-	    (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
 	    (:subl 8 :ecx)
 	    (:jmp 'continue-save-eax-ebx)))
    continue-save-eax-ebx
     (:testl 4 :ecx)
     (:jnz '(:sub-program (odd-keywords)
-	    (:orl 32 (:ebp -16))
-	    (:andl -8 :ecx)
-	    (:jmp 'continue-from-odd-keywords)))
+	    (:locally (:orl #x10 (:edi (:edi-offset scratch2))))
+	    (:ret)))
    continue-from-odd-keywords
     (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos
     (:xorl :edx :edx)			; EDX scans the args, last-to-first.
@@ -780,16 +781,15 @@
     ;; EAX: (presumed) keyword, EBX corresponding value.
     (:globally (:cmpl :eax (:edi (:edi-offset allow-other-keys-symbol))))
     (:je '(:sub-program (found-allow-other-keys)
-	   ;; store boolean EBX in bit 2 of (ebx -16).
-	   (:andl -8 (:ebp -16))
+	   (:locally (:andl #x-21 (:edi (:edi-offset scratch2)))) ; Signal :allow-other-keys nil
 	   (:cmpl :edi :ebx)
 	   (:je 'finished-keyword-search)
-	   (:orl 4 (:ebp -16))		; Signal :allow-other-keys t
+	   (:locally (:orl #x20 (:edi (:edi-offset scratch2)))) ; Signal :allow-other-keys t
 	   (:jmp 'finished-keyword-search)))
     (:leal (:eax -5) :ecx)
     (:testb 5 :cl)
     (:jnz '(:sub-program (keyword-not-symbol)
-	    (:orl 16 (:ebp -16))	; Signal keyword-not-symbol
+	    (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol
 	    (:jmp 'finished-keyword-search)))
     (:movl (:esi (:offset movitz-funobj num-jumpers))
 	   :ecx)
@@ -800,7 +800,7 @@
     (:je 'found-keyword)
     (:testb 1 (:esi :ecx (:offset movitz-funobj constant0)))
     (:jz '(:sub-program (keyword-not-fund)
-	   (:orl 8 (:ebp -16))		; signal unknown-keyword
+	   (:locally (:orl 4 (:edi (:edi-offset scratch2)))) ; signal unknown-keyword
 	   (:jmp 'finished-keyword-search)))
     (:addl 4 :ecx)
     (:jmp 'position-search-loop)
@@ -808,9 +808,9 @@
    found-keyword
     (:subw (:esi (:offset movitz-funobj num-jumpers)) :cx)
     (:negl :ecx)
-    (:movl :ebx (:ebp -20 (:ecx 2)))
+    (:movl :ebx (:ebp -16 (:ecx 2)))
     (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx))
-    (:movl :ebx (:ebp -20 (:ecx 2) -4))
+    (:movl :ebx (:ebp -16 (:ecx 2) -4))
     
    finished-keyword-search
     (:addl 8 :edx)
@@ -818,21 +818,18 @@
     (:ja 'scan-args-loop)
 
    check-arg0-arg1
-    (:locally (:cmpl -1 (:edi (:edi-offset scratch1))))
-    (:jne '(:sub-program (search-eax-ebx)
-	    ;; Search one more keyword, in arg0 and arg1
-	    (:locally (:movl (:edi (:edi-offset scratch1)) :eax))
-	    (:locally (:movl (:edi (:edi-offset scratch2)) :ebx))
-	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch1))))
-	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2))))
-	    (:jmp 'start-keyword-search)))
-    (:locally (:cmpl -1 (:edi (:edi-offset scratch2))))
-    (:jne '(:sub-program (search-ebx)
-	    ;; Search one more keyword, in arg1 and last on-stack.
-	    (:locally (:movl (:edi (:edi-offset scratch2)) :eax))
-	    (:movl (:ebp :edx 8) :ebx)	    
-	    (:locally (:movl #xffffffff (:edi (:edi-offset scratch2))))
-	    (:jmp 'start-keyword-search)))
+    (:locally (:subl 4 (:edi (:edi-offset scratch1))))
+    (:jc '(:sub-program (search-eax-ebx)
+	   ;; Search one more keyword, in arg0 and arg1
+	   (:movl (:ebp -8) :eax)
+	   (:movl (:ebp -12) :ebx)
+	   (:jmp 'start-keyword-search)))
+    (:locally (:subl 4 (:edi (:edi-offset scratch1))))
+    (:jc '(:sub-program (search-ebx)
+	   ;; Search one more keyword, in arg1 and last on-stack.
+	   (:movl (:ebp -12) :eax)
+	   (:movl (:ebp :edx 8) :ebx)	    
+	   (:jmp 'start-keyword-search)))
     (:ret)))
 
 (define-primitive-function decode-keyargs-foo ()



From ffjeld at common-lisp.net  Mon Feb 19 20:24:38 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 15:24:38 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070219202438.0108E7D002@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
First implementation of new &key-parsing strategy.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/17 19:24:28	1.174
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/19 20:24:38	1.175
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.174 2007/02/17 19:24:28 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.175 2007/02/19 20:24:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -789,6 +789,9 @@
 	(multiple-value-bind (const-list num-jumpers jumpers-map borrower-map)
 	    (layout-funobj-vector all-constants-plist
 				  all-key-args-constants
+				  #+ignore (mapcar (lambda (x)
+						     (cons (movitz-read x) 1))
+						   '(:a :b :c :d))
 				  all-jumper-sets
 				  (borrowed-bindings funobj))
 	  (setf (movitz-funobj-num-jumpers funobj) num-jumpers
@@ -2655,7 +2658,7 @@
 (defun make-binding-map () nil)
 
 (defun new-binding-located-p (binding map)
-  (check-type binding (or binding (cons keyword binding)))
+  (check-type binding (or null binding (cons keyword binding)))
   (and (assoc binding map) t))
 
 (defun frame-map-size (map)
@@ -2830,19 +2833,9 @@
 			(when sub (process sub))))))
       (process code)
       (map nil #'process include-programs))
-    (if (not key-args-set)
-	(values constants jumper-sets nil)
-      (loop with key-args-constants = nil
-	  for (object count) on constants by #'cddr
-	  if (not (member object key-args-set))
-	  append (list object count) into non-key-constants
-	  else
-	  do (setf key-args-constants
-	       (merge 'list key-args-constants (list (cons object count)) #'<
-		      :key (lambda (x)
-			     (position (car x) key-args-set))))
-	  finally
-	    (return (values non-key-constants jumper-sets key-args-constants))))))
+    (loop for key-arg in key-args-set
+	do (remf constants key-arg))
+    (values constants jumper-sets key-args-set)))
 
 (defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings)
   (let* ((jumpers (loop with x
@@ -2851,7 +2844,12 @@
 		      do (setf x (nconc x (copy-list set)))
 		      finally (return x)))
 	 (num-jumpers (length jumpers))
-	 (stuff (append key-args-constants
+	 (stuff (append (mapcar (lambda (c)
+				  (cons c 1))
+				key-args-constants)
+			(when key-args-constants
+			  (list (cons (movitz-read 0)
+				      1)))
 			(sort (loop for (constant count) on constants by #'cddr
 				  unless (or (eq constant *movitz-nil*)
 					     (eq constant (image-t-symbol *image*)))
@@ -3136,9 +3134,11 @@
 			       (funobj-binding))))
 			  (:init-lexvar
 			   (destructuring-bind (binding &key init-with-register init-with-type
-							     protect-registers protect-carry)
+							     protect-registers protect-carry
+							     shared-reference-p)
 			       (cdr instruction)
-			     (declare (ignore protect-registers protect-carry init-with-type))
+			     (declare (ignore protect-registers protect-carry init-with-type
+					      shared-reference-p))
 			     (cond
 			      ((not init-with-register)
 			       (take-note-of-init binding pc))
@@ -3320,6 +3320,9 @@
 		 (when (and (binding-lended-p binding)
 			    (not (typep binding 'borrowed-binding))
 			    (not (getf (binding-lending binding) :stack-cons-location)))
+		   #+ignore
+		   (assert (not (typep binding 'keyword-function-argument)) ()
+		     "Can't lend keyword binding ~S." binding)
 		   ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
 		   (let ((cons-pos (frame-map-next-free-location frame-map function-env 2)))
 		     (setf (new-binding-location (cons :lended-cons binding) frame-map)
@@ -3346,6 +3349,40 @@
 			(plusp (car (gethash binding var-counts '(0)))))
 	       (setf (new-binding-location binding frame-map)
 		 (forwarding-binding-target binding))))	     
+      ;; Keyword bindings
+      (flet ((set-exclusive-location (binding location)
+	       (assert (not (rassoc location frame-map))
+		   () "Fixed location ~S for ~S is taken by ~S."
+		   location binding (rassoc location frame-map))
+	       (setf (new-binding-location binding frame-map) location)))
+	(when (key-vars-p function-env)
+	  (when (= 0 (rest-args-position function-env))
+	    (set-exclusive-location (loop for var in (required-vars function-env)
+					as binding = (movitz-binding var function-env nil)
+					thereis (when (= 0 (function-argument-argnum binding))
+						  binding))
+				    1))
+	  (when (>= 1 (rest-args-position function-env))
+	    (set-exclusive-location (loop for var in (required-vars function-env)
+					as binding = (movitz-binding var function-env nil)
+					thereis (when (= 1 (function-argument-argnum binding))
+						  binding))
+				    2)))
+	(loop for key-var in (key-vars function-env)
+	    as key-binding =
+	      (or (movitz-binding key-var function-env nil)
+		  (error "No binding for key-var ~S." key-var))
+	    as supplied-p-binding =
+	      (when (optional-function-argument-supplied-p-var key-binding)
+		(or (movitz-binding (optional-function-argument-supplied-p-var key-binding)
+				    function-env nil)
+		    (error "No binding for supplied-p-var ~S."
+			   (optional-function-argument-supplied-p-var key-binding))))
+	    as location upfrom 3 by 2
+	    do (set-exclusive-location key-binding location)
+	       (assert supplied-p-binding)
+	       (set-exclusive-location supplied-p-binding (1+ location))))
+      ;; Now, use assing-env-bindings on the remaining bindings.
       (loop for env in
 	    (loop with z = nil
 		for b being the hash-keys of var-counts using (hash-value c)
@@ -4293,7 +4330,7 @@
   "From a (normal) <lambda-list>, add bindings to <env>."
   (let ((arg-pos 0))
     (multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p
-			  min-args max-args edx-var oddeven key-p)
+			  min-args max-args edx-var oddeven key-vars-p)
 	(decode-normal-lambda-list lambda-list)
       (declare (ignore auxes))
       (setf (min-args env) min-args
@@ -4356,6 +4393,8 @@
 		    (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
 					       :name supplied-p-parameter)))
 		  formal)))
+	(when (or rest-var key-vars-p)
+	  (setf (rest-args-position env) arg-pos))
 	(when rest-var
 	  (check-type rest-var symbol)
 	  (let ((formal (shadow-when-special rest-var env)))
@@ -4363,11 +4402,30 @@
 	    (movitz-env-add-binding env (make-instance 'rest-function-argument
 				       :name formal
 				       :argnum (post-incf arg-pos)))))
-	(when key-p
-	  ;; We need to check at run-time whether keyword checking is supressed or not.
-	  (setf (allow-other-keys-var env)
-	    (movitz-env-add-binding env (make-instance 'located-binding
-					  :name (gensym "allow-other-keys-var-")))))
+;;;	(when key-vars-p
+;;;	  ;; We need to check at run-time whether keyword checking is supressed or not.
+;;;	  (setf (allow-other-keys-var env)
+;;;	    (movitz-env-add-binding env (make-instance 'located-binding
+;;;					  :name (gensym "allow-other-keys-var-")))))
+	(when key-vars-p
+	  (setf (key-vars-p env) t)
+	  (when (>= 1 (rest-args-position env))
+	    (let ((name (gensym "save-ebx-for-keyscan")))
+	      (setf (required-vars env)
+		(append (required-vars env)
+			(list name)))
+	      (movitz-env-add-binding env (make-instance 'register-required-function-argument
+					    :name name
+					    :argnum 1
+					    :declarations '(muerte.cl:ignore)))
+	      (setf (movitz-env-get name 'ignore nil env) t)))
+	  (when (= 0 (rest-args-position env))
+	    (let ((name (gensym "save-eax-for-keyscan")))
+	      (push name (required-vars env))
+	      (movitz-env-add-binding env (make-instance 'register-required-function-argument
+					    :name name
+					    :argnum 0))
+	      (setf (movitz-env-get name 'ignore nil env) t))))
 	(setf (key-vars env)
 	  (loop for spec in key-vars
 	      with rest-var-name =
@@ -4379,21 +4437,23 @@
 							 :argnum (post-incf arg-pos)))
 			   name)))
 	      collect
-		(multiple-value-bind (formal keyword-name init-form supplied-p-parameter)
+		(multiple-value-bind (formal keyword-name init-form supplied-p)
 		    (decode-keyword-formal spec)
-		  (setf formal (shadow-when-special formal env))
-		  (movitz-env-add-binding env (make-instance 'keyword-function-argument
-					     :name formal
-					     'init-form init-form
-					     'supplied-p-var supplied-p-parameter
-					     :keyword-name keyword-name
-					     :rest-var-name rest-var-name))
-		  (when supplied-p-parameter
-		    (setf supplied-p-parameter
-		      (shadow-when-special supplied-p-parameter env))
+		  (let ((formal
+			 (shadow-when-special formal env))
+			(supplied-p-parameter
+			 (or supplied-p
+			     (gensym "supplied-p-"))))
+		    (movitz-env-add-binding env (make-instance 'keyword-function-argument
+						  :name formal
+						  'init-form init-form
+						  'supplied-p-var supplied-p-parameter
+						  :keyword-name keyword-name
+						  :rest-var-name rest-var-name))
 		    (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
-					       :name supplied-p-parameter)))
-		  formal)))
+						  :name (shadow-when-special supplied-p-parameter env)))
+		    formal))))
+	#+ignore
 	(multiple-value-bind (key-decode-map key-decode-shift)
 	    (best-key-encode (key-vars env))  
 	  (setf (key-decode-map env) key-decode-map
@@ -4508,7 +4568,7 @@
 		 (edx-location
 		  (and (edx-var env)
 		       (new-binding-location (edx-var env) frame-map :default nil))))
-	    ;; (warn "l0: ~S, l1: ~S" location-0 location-1)
+	    #+ignore (warn "l0: ~S, l1: ~S" location-0 location-1)
 	    (assert (not (and location-0
 			      (eql location-0 location-1))) ()
 	      "Compiler bug: two bindings in same location.")
@@ -4775,8 +4835,7 @@
 	(required-vars (required-vars env))
 	(optional-vars (optional-vars env))
 	(rest-var (rest-var env))
-	(key-vars (key-vars env))
-	(allow-other-keys-p (allow-other-keys-p env)))
+	(key-vars (key-vars env)))
     (when (and (not rest-var)
 	       key-vars
 	       (not (= 1 (length key-vars))))
@@ -4912,148 +4971,81 @@
 			  :init-with-type list))))
       (when key-vars
 	(play-with-keys key-vars))
-      (cond
+      (when (key-vars-p env)
        ;; &key processing..
-       ((and (not rest-var)
-	     (= 1 (length key-vars)))
-	(let* ((key-var-name (decode-keyword-formal (first key-vars)))
-	       (binding (movitz-binding key-var-name env))
-	       (position (function-argument-argnum
-			  (movitz-binding (keyword-function-argument-rest-var-name binding) env)))
-	       (supplied-p-var (optional-function-argument-supplied-p-var binding))
-	       (supplied-p-binding (movitz-binding supplied-p-var env)))
-	  (setq need-normalized-ecx-p t)
-	  (cond
-	   ((and (movitz-constantp (optional-function-argument-init-form binding))
-		 (< 1 position))
-	    `((:init-lexvar ,binding)
-	      ,@(when supplied-p-var
-		  `((:init-lexvar ,supplied-p-binding)))
-	      ,@(compiler-call #'compile-form
-		  :form (list 'muerte.cl:quote
-			      (eval-form (optional-function-argument-init-form binding) env nil))
-		  :funobj funobj
-		  :env env
-		  :result-mode :ebx)
-	      ,@(when supplied-p-var
-		  `((:store-lexical ,supplied-p-binding :edi :type null)))
-	      (:arg-cmp ,(+ 2 position))
-	      (:jb 'default-done)
-	      (:movl (:ebp (:ecx 4) ,(* -4 (1- position))) :eax)
-	      (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :eax :op :cmpl)
-	      ,@(if allow-other-keys-p
-		    `((:jne 'default-done))
-		  `((:jne '(:sub-program (unknown-key) (:int 101)))))
-	      ,@(when supplied-p-var
-		  `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax)
-		    (:store-lexical ,supplied-p-binding :eax
-				    :type (eql ,(image-t-symbol *image*)))))
-	      (:movl (:ebp (:ecx 4) ,(* -4 (1- (1+ position)))) :ebx)
-	      default-done
-	      (:store-lexical ,binding :ebx :type t)))
-	   (t `((:init-lexvar ,binding)
-		,@(when supplied-p-var
-		    `((:init-lexvar ,supplied-p-binding)))
-		(:arg-cmp ,(+ 2 position))
-		(:jb '(:sub-program (default)
-		       ,@(append
-			  (when supplied-p-var
-			    `((:store-lexical ,supplied-p-binding :edi
-					      :type null)))
-			  (compiler-call #'compile-form
-			    :form (optional-function-argument-init-form binding)
-			    :funobj funobj
-			    :env env
-			    :result-mode :ebx)
-			  `((:jmp 'default-done)))))
-		,@(case position
-		    (0 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
-					 :eax :op :cmpl)))
-		    (1 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
-					 :ebx :op :cmpl)))
-		    (t `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
-					 :eax :op :cmpl))))
-		,@(if allow-other-keys-p
-		      `((:jne 'default))
-		    `((:jne '(:sub-program (unknown-key) (:int 101)))))
-		,@(when supplied-p-var
-		    `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax)
-		      (:store-lexical ,supplied-p-binding :eax
-				      :type (eql ,(image-t-symbol *image*)))))
-		,@(case position
-		    (0 nil)		; it's already in ebx
-		    (t `((:movl (:ebp (:ecx 4) ,(* -4 (1- (1+ position)))) :ebx))))
-		default-done
-		(:store-lexical ,binding :ebx :type t))))))
-       (t #+ignore
-	  (pushnew (movitz-print (movitz-funobj-name funobj))
-		   (aref *xx* (length key-vars)))
-	  #+ignore
-	  (when key-vars
-	    (warn "KEY-FUN: ~D" (length key-vars)))
-	  (append
-	   `((:declare-key-arg-set ,@(mapcar (lambda (k)
-					       (movitz-read
-						(keyword-function-argument-keyword-name
-						 (movitz-binding (decode-keyword-formal k) env))))
-					     key-vars)))
-	   (loop with rest-binding = (movitz-binding rest-var env)
-	       for key-var in key-vars
-	       as key-var-name = (decode-keyword-formal key-var)
-	       as binding = (movitz-binding key-var-name env)
-	       as supplied-p-var = (optional-function-argument-supplied-p-var binding)
-	       as supplied-p-binding = (movitz-binding supplied-p-var env)
-	       and keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name))
-	       and keyword-not-supplied-label = (gensym)
-	       do (assert binding)
-	       if (not (movitz-constantp (optional-function-argument-init-form binding)))
-	       append
-		 `((:init-lexvar ,binding)
-		   (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx)
-		   (:load-lexical ,rest-binding :ebx)
-		   (:call (:edi ,(global-constant-offset 'keyword-search)))
-		   (:jz ',keyword-not-supplied-label)
-		   (:store-lexical ,binding :eax :type t)
-		   ,@(when supplied-p-var
-		       `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax)
-			 (:init-lexvar ,supplied-p-binding
-				       :init-with-register :eax
-				       :init-with-type (eql ,(image-t-symbol *image*)))))
-		   (:jmp ',keyword-ok-label)
-		   ,keyword-not-supplied-label
-		   ,@(when supplied-p-var
-		       `((:store-lexical ,supplied-p-binding :edi :type null)))
+	(setq need-normalized-ecx-p t)
+	(append
+	 `((:declare-key-arg-set ,@(mapcar (lambda (k)
+					     (movitz-read
+					      (keyword-function-argument-keyword-name
+					       (movitz-binding (decode-keyword-formal k) env))))
+					   key-vars)))
+	 (make-immediate-move (* +movitz-fixnum-factor+
+				 (rest-args-position env))
+			      :edx)
+	 `((:call (:edi ,(global-constant-offset 'decode-keyargs-default))))
+	 (unless (allow-other-keys-p env)
+	   `((:testl :eax :eax)
+	     (:jnz '(:sub-program (unknown-keyword)
+		     (:int 72)))))
+	 (loop for key-var in key-vars
+	     as key-location upfrom 3 by 2
+	     as key-var-name =
+	       (decode-keyword-formal key-var)
+	     as binding =
+	       (movitz-binding key-var-name env)
+	     as supplied-p-binding =
+	       (movitz-binding (optional-function-argument-supplied-p-var binding)
+			       env)
+	     as keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name))
+	     do (assert binding)
+	     ;;  (not (movitz-constantp (optional-function-argument-init-form binding)))
+	     append
+	       `((:init-lexvar ,binding
+			       :init-with-register ,binding
+			       :init-with-type t
+			       :shared-reference-p t)
+		 (:init-lexvar ,supplied-p-binding
+			       :init-with-register ,supplied-p-binding
+			       :init-with-type t
+			       :shared-reference-p t))
+	     append
+	       (when (optional-function-argument-init-form binding)
+		 `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location))))
+		   (:jne ',keyword-ok-label)
 		   ,@(compiler-call #'compile-form
 		       :form (optional-function-argument-init-form binding)

[187 lines skipped]



From ffjeld at common-lisp.net  Mon Feb 19 20:24:48 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 15:24:48 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070219202448.A98537C03D@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
First implementation of new &key-parsing strategy.


--- /project/movitz/cvsroot/movitz/environment.lisp	2007/02/15 22:01:02	1.18
+++ /project/movitz/cvsroot/movitz/environment.lisp	2007/02/19 20:24:42	1.19
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.18 2007/02/15 22:01:02 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.19 2007/02/19 20:24:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -191,9 +191,9 @@
     :accessor oddeven-args)
    (allow-other-keys-p
     :accessor allow-other-keys-p)
-   (allow-other-keys-var
+   (rest-args-position
     :initform nil
-    :accessor allow-other-keys-var)
+    :accessor rest-args-position)
    (edx-var
     :initform nil
     :accessor edx-var)
@@ -206,6 +206,9 @@
    (rest-var
     :initform nil
     :accessor rest-var)
+   (key-vars-p
+    :initform nil
+    :accessor key-vars-p)
    (key-vars
     :initform nil
     :accessor key-vars)



From ffjeld at common-lisp.net  Mon Feb 19 20:24:52 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 15:24:52 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070219202452.552FD5200F@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv30606

Modified Files:
	basic-functions.lisp 
Log Message:
First implementation of new &key-parsing strategy.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp	2006/03/21 20:20:20	1.21
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp	2007/02/19 20:24:51	1.22
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.21 2006/03/21 20:20:20 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.22 2007/02/19 20:24:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -432,4 +432,36 @@
 	    (setf (memref object offset :index i :type :character)
 	      (char value j))))))))
   value)
-     
+
+
+
+(define-primitive-function blah ()
+  "foo"
+  (with-inline-assembly (:returns :multiple-values)
+    ;; EAX: (presumed) keyword
+    (:globally (:cmpl :eax (:edi (:edi-offset allow-other-keys-symbol))))
+    (:je '(:sub-program (found-allow-other-keys)
+	   				; XXX
+	   (:ret)))
+    (:leal (:ebx -7) :ecx)
+    (:testb 7 :cl)
+    (:jnz '(:sub-program ()
+	    (:xorl :ecx :ecx)		; hash of nil is 0
+	    (:cmpl :edi :ebx)
+	    (:je 'proceed-with-nil-key)
+	    (:movl :ebx :eax)
+	    (:movb 0 :cl)
+	    (:int 72)))
+    (:xorl :ecx :ecx)
+    (:movw (:eax (:offset movitz-symbol hash-key)) :cx)
+   proceed-with-nil-key
+    ;; We now have symbol's basic sxhash in CX.
+    (:xorl :edx :edx)
+    (:leal ((:ecx 4) :edx) :edx)
+    (:andl (:esi (:offset movitz-funobj constant0))
+	   :edx)
+    
+    (:ret)
+    
+    ))
+



From ffjeld at common-lisp.net  Mon Feb 19 20:24:57 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 15:24:57 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070219202457.1FA1E111CF@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv30647

Modified Files:
	interrupt.lisp 
Log Message:
First implementation of new &key-parsing strategy.


--- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp	2006/05/06 21:15:46	1.52
+++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp	2007/02/19 20:24:54	1.53
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.52 2006/05/06 21:15:46 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.53 2007/02/19 20:24:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -382,6 +382,14 @@
 	   (error "Not a function: ~S" (dereference $edx)))
 	  (70
 	   (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (dereference $eax)))
+	  (72
+	   (ecase (dereference $eax)
+	     (1 (error 'program-error
+		       :format-control "Illegal keyword argument."))
+	     (2 (error 'program-error
+		       :format-control "Keyword not a symbol."))
+	     (4 (error 'program-error
+		       :format-control "Odd number of keyword arguments."))))
 	  (98
 	   (let ((name (dereference $edx)))
 	     (when (symbolp name)



From ffjeld at common-lisp.net  Mon Feb 19 20:25:00 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 15:25:00 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070219202500.132851E06F@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv30688

Modified Files:
	primitive-functions.lisp 
Log Message:
First implementation of new &key-parsing strategy.


--- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/18 16:31:42	1.67
+++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/19 20:24:59	1.68
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.67 2007/02/18 16:31:42 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.68 2007/02/19 20:24:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -740,13 +740,15 @@
   "Decode keyword arguments. Results are placed in stack-frame,
 starting at (:ebp -16)."
   (with-inline-assembly (:returns :multiple-values)
-    ;; ECX: numargs (fixnum)
+    ;; ECX: numargs (u32)
     ;; EDX: arg-position of first keyword (fixnum)
     ;; (:ebp  -8) arg0 (if needed)
     ;; (:ebp -12) arg1 (if needed)
 
+    (:shll 2 :ecx)
     (:subl :edx :ecx)			; find stop-pos
     (:jbe '(:sub-program (no-key-args)
+	    (:xorl :eax :eax)		; No errors
 	    (:ret)))
 
     (:locally (:movl :edx (:edi (:edi-offset scratch1)))) ; first-key-position
@@ -764,7 +766,7 @@
     (:testl 4 :ecx)
     (:jnz '(:sub-program (odd-keywords)
 	    (:locally (:orl #x10 (:edi (:edi-offset scratch2))))
-	    (:ret)))
+	    (:int 72)))
    continue-from-odd-keywords
     (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos
     (:xorl :edx :edx)			; EDX scans the args, last-to-first.
@@ -785,12 +787,13 @@
 	   (:cmpl :edi :ebx)
 	   (:je 'finished-keyword-search)
 	   (:locally (:orl #x20 (:edi (:edi-offset scratch2)))) ; Signal :allow-other-keys t
-	   (:jmp 'finished-keyword-search)))
+	   (:jmp 'start-keyword-search-symbol)))
     (:leal (:eax -5) :ecx)
     (:testb 5 :cl)
     (:jnz '(:sub-program (keyword-not-symbol)
 	    (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol
-	    (:jmp 'finished-keyword-search)))
+	    (:int 72)))
+   start-keyword-search-symbol
     (:movl (:esi (:offset movitz-funobj num-jumpers))
 	   :ecx)
     (:andl #xfffc :ecx)
@@ -830,6 +833,13 @@
 	   (:movl (:ebp -12) :eax)
 	   (:movl (:ebp :edx 8) :ebx)	    
 	   (:jmp 'start-keyword-search)))
+    ;; if there was :allow-other-keys t, clear the unknown-keyword error flag.
+    (:locally (:movl (:edi (:edi-offset scratch2)) :eax))
+    (:movl :eax :ecx)
+    (:andl #x20 :ecx)
+    (:shrl 3 :ecx)
+    (:xorl 4 :ecx)
+    (:andl :ecx :eax)
     (:ret)))
 
 (define-primitive-function decode-keyargs-foo ()



From ffjeld at common-lisp.net  Mon Feb 19 21:57:34 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 16:57:34 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070219215734.85B9D61058@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Remove old check for odd keyargs, since the new &key-parser does it
for us.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/19 20:24:38	1.175
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/19 21:57:33	1.176
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.175 2007/02/19 20:24:38 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.176 2007/02/19 21:57:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -4704,37 +4704,22 @@
 	    eax-ebx-code
 	    (make-stack-setup-code stack-setup-size)
 	    (when need-normalized-ecx-p
-	      (let ((oddeven-ok (gensym "oddeven-ok-")))
-		(append (cond
-			 ;; normalize arg-count in ecx..
-			 ((and max-args (= min-args max-args))
-			  (error "huh?"))
-			 ((and max-args (<= 0 min-args max-args #x7f))
-			  `((:andl #x7f :ecx)))
-			 ((>= min-args #x80)
-			  `((:shrl 8 :ecx)))
-			 (t (let ((normalize (make-symbol "normalize-ecx"))
-				  (normalize-done (make-symbol "normalize-ecx-done")))
-			      `((:testb :cl :cl)
-				(:js '(:sub-program (,normalize)
-				       (:shrl 8 :ecx)
-				       (:jmp ',normalize-done)))
-				(:andl #x7f :ecx)
-				,normalize-done))))
-			(when (and (oddeven-args env)
-				   (optional-vars env))
-			  `((:cmpl ,(length (optional-vars env)) :ecx)
-			    (:jbe ',oddeven-ok)))
-			(case (oddeven-args env)
-			  (:even
-			   `((:testb 1 :cl)
-			     (:jnz '(:sub-program () (:int 102)))))
-			  (:odd
-			   `((:testb 1 :cl)
-			     (:jz '(:sub-program () (:int 102))))))
-			(when (and (oddeven-args env)
-				   (optional-vars env))
-			  (list oddeven-ok)))))
+	      (append (cond
+		       ;; normalize arg-count in ecx..
+		       ((and max-args (= min-args max-args))
+			(error "huh?"))
+		       ((and max-args (<= 0 min-args max-args #x7f))
+			`((:andl #x7f :ecx)))
+		       ((>= min-args #x80)
+			`((:shrl 8 :ecx)))
+		       (t (let ((normalize (make-symbol "normalize-ecx"))
+				(normalize-done (make-symbol "normalize-ecx-done")))
+			    `((:testb :cl :cl)
+			      (:js '(:sub-program (,normalize)
+				     (:shrl 8 :ecx)
+				     (:jmp ',normalize-done)))
+			      (:andl #x7f :ecx)
+			      ,normalize-done))))))
 	    (when edx-needs-saving-p
 	      `((:movl :edx (:ebp ,(stack-frame-offset (new-binding-location (edx-var env) frame-map))))))
 	    eax-ebx-code-post-stackframe



From ffjeld at common-lisp.net  Mon Feb 19 21:57:49 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 16:57:49 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070219215749.50050111CD@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Minor tweak.


--- /project/movitz/cvsroot/movitz/image.lisp	2007/02/18 14:53:07	1.108
+++ /project/movitz/cvsroot/movitz/image.lisp	2007/02/19 21:57:49	1.109
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.108 2007/02/18 14:53:07 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.109 2007/02/19 21:57:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -779,7 +779,7 @@
 			:start-address start-address
 			:movitz-features '(:movitz)
 			:function-code-sizes
-			(if (boundp '*image*)
+			(if (and (boundp '*image*) *image*)
 			    (copy-hash-table (function-code-sizes *image*))
 			  (make-hash-table :test #'equal))
 			init-args)))



From ffjeld at common-lisp.net  Mon Feb 19 21:58:27 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 19 Feb 2007 16:58:27 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070219215827.E535019008@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8169

Modified Files:
	primitive-functions.lisp 
Log Message:
In decode-keyargs-default, provide error in eax rathern than scratch2.


--- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/19 20:24:59	1.68
+++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp	2007/02/19 21:58:27	1.69
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.68 2007/02/19 20:24:59 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.69 2007/02/19 21:58:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -765,7 +765,8 @@
    continue-save-eax-ebx
     (:testl 4 :ecx)
     (:jnz '(:sub-program (odd-keywords)
-	    (:locally (:orl #x10 (:edi (:edi-offset scratch2))))
+	    ;; (:locally (:orl #x10 (:edi (:edi-offset scratch2))))
+	    (:movl #x10 :eax)
 	    (:int 72)))
    continue-from-odd-keywords
     (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos
@@ -791,7 +792,8 @@
     (:leal (:eax -5) :ecx)
     (:testb 5 :cl)
     (:jnz '(:sub-program (keyword-not-symbol)
-	    (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol
+	    ;; (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol
+	    (:movl #x8 :eax)
 	    (:int 72)))
    start-keyword-search-symbol
     (:movl (:esi (:offset movitz-funobj num-jumpers))



From ffjeld at common-lisp.net  Tue Feb 20 20:33:30 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue, 20 Feb 2007 15:33:30 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070220203330.6B5A147005@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fixed nasty in special-operator-let that would erroneously remove
init-forms with side-effects.


--- /project/movitz/cvsroot/movitz/special-operators-cl.lisp	2005/09/16 22:50:08	1.49
+++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp	2007/02/20 20:33:30	1.50
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.49 2005/09/16 22:50:08 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.50 2007/02/20 20:33:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -155,7 +155,8 @@
 		       :env local-env))))
 	    (compiler-values-bind (&all body-values &code body-code &returns body-returns)
 		(compile-body)
-;;;	      (print-code 'body body-code)
+	      ;; (print-code 'body body)
+	      ;; (print-code 'body-code body-code)
 	      (let ((first-binding (movitz-binding (caar binding-var-codes) local-env nil)))
 		(cond
 		 ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ?
@@ -368,6 +369,8 @@
 		      (compiler-values (body-values)
 			:returns body-returns
 			:producer (default-compiler-values-producer)
+			:functional-p (and (body-values :functional-p)
+					   (every #'fourth binding-var-codes))
 			:modifies let-modifies
 			:code code))))))))))))
 



From ffjeld at common-lisp.net  Tue Feb 20 21:55:31 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue, 20 Feb 2007 16:55:31 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070220215531.C17F2761AC@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv27165

Modified Files:
	sequences.lisp 
Log Message:
Remove unused args.


--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/10 11:56:28	1.33
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2007/02/20 21:55:29	1.34
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.33 2006/04/10 11:56:28 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.34 2007/02/20 21:55:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1755,10 +1755,9 @@
    (t (error "Can't concatenate ~S yet: ~:S" result-type sequences))))
 
 
-(defun substitute (newitem olditem sequence &rest args 
+(defun substitute (newitem olditem sequence
 		   &key (test 'eql) test-not (start 0) end count (key 'identity) from-end)
   "=> result-sequence"
-  (declare (dynamic-extent args))
   (when test-not
     (setf test (complement test-not)))
   (with-funcallable (test (if test-not (complement test-not) test))
@@ -1767,10 +1766,9 @@
 		   :count count :key key
 		   :from-end from-end)))
 
-(defun nsubstitute (newitem olditem sequence &rest args 
+(defun nsubstitute (newitem olditem sequence
 		    &key (test 'eql) test-not (start 0) end count (key 'identity) from-end)
   "=> result-sequence"
-  (declare (dynamic-extent args))
   (when test-not
     (setf test (complement test-not)))
   (with-funcallable (test (if test-not (complement test-not) test))



From ffjeld at common-lisp.net  Tue Feb 20 21:57:14 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue, 20 Feb 2007 16:57:14 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070220215714.AB096281E5@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fix compilation of unused &key vars.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/19 21:57:33	1.176
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/20 21:57:13	1.177
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.176 2007/02/19 21:57:33 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.177 2007/02/20 21:57:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1473,7 +1473,7 @@
 ;;;;
 
 (defun print-code (x code)
-  (let ((*print-level* 3))
+  (let ((*print-level* 4))
     (format t "~&~A code:~{~&  ~A~}" x code))
   code)
 
@@ -2691,9 +2691,12 @@
 		      (find-if (lambda (b-loc)
 				 (destructuring-bind (binding . binding-location)
 				     b-loc
-				   (or (and (not (bindingp binding))
+				   (or (and (eq binding nil) ; nil means "back off!"
 					    (eql sub-location binding-location))
-				       (and (eql sub-location (stack-location binding))
+				       (and (not (bindingp binding))
+					    (eql sub-location binding-location))
+				       (and (bindingp binding)
+					    (eql sub-location (stack-location binding))
 					    (labels
 						((z (b)
 						   (when b
@@ -2715,7 +2718,8 @@
 	      (append values (list binding))
 	      (list new-value)
 	      `(let ((,(car stores) (progn
-				      (assert (not (new-binding-located-p ,binding-var ,getter)))
+				      (assert (or (null binding)
+						  (not (new-binding-located-p ,binding-var ,getter))))
 				      (check-type ,new-value (or keyword
 								 binding
 								 (integer 0 *)
@@ -3145,7 +3149,8 @@
 			      (init-with-register
 			       (take-note-of-binding binding t pc)
 			       (when (and (typep init-with-register 'binding)
-					  (not (typep binding 'forwarding-binding))) ; XXX
+					  (not (typep binding 'forwarding-binding))
+					  (not (typep binding 'keyword-function-argument))) ; XXX
 				 (take-note-of-binding init-with-register))))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
@@ -3369,19 +3374,22 @@
 						  binding))
 				    2)))
 	(loop for key-var in (key-vars function-env)
-	    as key-binding =
-	      (or (movitz-binding key-var function-env nil)
-		  (error "No binding for key-var ~S." key-var))
-	    as supplied-p-binding =
+	    as key-binding = (or (movitz-binding key-var function-env nil)
+				 (error "No binding for key-var ~S." key-var))
+	    as used-key-binding =
+	      (when (plusp (car (gethash key-binding var-counts '(0))))
+		key-binding)
+	    as used-supplied-p-binding =
 	      (when (optional-function-argument-supplied-p-var key-binding)
-		(or (movitz-binding (optional-function-argument-supplied-p-var key-binding)
-				    function-env nil)
-		    (error "No binding for supplied-p-var ~S."
-			   (optional-function-argument-supplied-p-var key-binding))))
+		(let ((b (or (movitz-binding (optional-function-argument-supplied-p-var key-binding)
+					     function-env nil)
+			     (error "No binding for supplied-p-var ~S."
+				    (optional-function-argument-supplied-p-var key-binding)))))
+		  (when (plusp (car (gethash key-binding var-counts '(0))))
+		    b)))
 	    as location upfrom 3 by 2
-	    do (set-exclusive-location key-binding location)
-	       (assert supplied-p-binding)
-	       (set-exclusive-location supplied-p-binding (1+ location))))
+	    do (set-exclusive-location used-key-binding location)
+	       (set-exclusive-location used-supplied-p-binding (1+ location))))
       ;; Now, use assing-env-bindings on the remaining bindings.
       (loop for env in
 	    (loop with z = nil
@@ -3595,7 +3603,7 @@
 				 'integer))
       (warn "ecx from ~S" binding)))
   (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
-    (warn "The variable ~S is used even if it was declared ignored."
+    (break "The variable ~S is used even if it was declared ignored."
 	  (binding-name binding)))
   (let ((binding (ensure-local-binding binding funobj))
 	(protect-registers (cons :edx protect-registers)))
@@ -4443,15 +4451,16 @@
 			 (shadow-when-special formal env))
 			(supplied-p-parameter
 			 (or supplied-p
-			     (gensym "supplied-p-"))))
+			     #+ignore (gensym "supplied-p-"))))
 		    (movitz-env-add-binding env (make-instance 'keyword-function-argument
 						  :name formal
 						  'init-form init-form
 						  'supplied-p-var supplied-p-parameter
 						  :keyword-name keyword-name
 						  :rest-var-name rest-var-name))
-		    (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
-						  :name (shadow-when-special supplied-p-parameter env)))
+		    (when supplied-p-parameter
+		      (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
+						    :name (shadow-when-special supplied-p-parameter env))))
 		    formal))))
 	#+ignore
 	(multiple-value-bind (key-decode-map key-decode-shift)
@@ -4980,30 +4989,31 @@
 	     as binding =
 	       (movitz-binding key-var-name env)
 	     as supplied-p-binding =
-	       (movitz-binding (optional-function-argument-supplied-p-var binding)
-			       env)
+	       (when (optional-function-argument-supplied-p-var binding)
+		 (movitz-binding (optional-function-argument-supplied-p-var binding)
+				 env))
 	     as keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name))
 	     do (assert binding)
 	     ;;  (not (movitz-constantp (optional-function-argument-init-form binding)))
 	     append
-	       `((:init-lexvar ,binding
-			       :init-with-register ,binding
-			       :init-with-type t
-			       :shared-reference-p t)
-		 (:init-lexvar ,supplied-p-binding
-			       :init-with-register ,supplied-p-binding
-			       :init-with-type t
-			       :shared-reference-p t))
-	     append
-	       (when (optional-function-argument-init-form binding)
-		 `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location))))
-		   (:jne ',keyword-ok-label)
-		   ,@(compiler-call #'compile-form
-		       :form (optional-function-argument-init-form binding)
-		       :env env
-		       :funobj funobj
-		       :result-mode binding)
-		   ,keyword-ok-label))
+	       (append `((:init-lexvar ,binding
+				       :init-with-register ,binding
+				       :init-with-type t
+				       :shared-reference-p t))
+		       (when supplied-p-binding
+			 `((:init-lexvar ,supplied-p-binding
+					 :init-with-register ,supplied-p-binding
+					 :init-with-type t
+					 :shared-reference-p t)))
+		       (when (optional-function-argument-init-form binding)
+			 `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location))))
+			   (:jne ',keyword-ok-label)
+			   ,@(compiler-call #'compile-form
+			       :form (optional-function-argument-init-form binding)
+			       :env env
+			       :funobj funobj
+			       :result-mode binding)
+			   ,keyword-ok-label)))
 ;;;	     else append
 ;;;		  nil
 		  #+ignore



From ffjeld at common-lisp.net  Tue Feb 20 23:11:22 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue, 20 Feb 2007 18:11:22 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070220231122.E797C38048@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8373

Modified Files:
	basic-macros.lisp 
Log Message:
Have CAR and CDR have side-effects (i.e. they signal errors if the
argumetn isn't a cons).


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2006/05/06 21:15:44	1.67
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2007/02/20 23:11:22	1.68
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.67 2006/05/06 21:15:44 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.68 2007/02/20 23:11:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -583,13 +583,13 @@
 
 (define-compiler-macro car (x)
   `(let ((cell ,x))
-     (with-inline-assembly-case (:side-effects nil)
+     (with-inline-assembly-case (:side-effects t)
        (do-case (t :register)
 	 (:cons-get :car (:lexical-binding cell) (:result-register))))))
 
 (define-compiler-macro cdr (x)
   `(let ((cell ,x))
-     (with-inline-assembly-case (:side-effects nil)
+     (with-inline-assembly-case (:side-effects t)
        (do-case (t :register)
 	 (:cons-get :cdr (:lexical-binding cell) (:result-register))))))
 



From ffjeld at common-lisp.net  Tue Feb 20 23:11:44 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Tue, 20 Feb 2007 18:11:44 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070220231144.4C1FA7C03E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8445

Modified Files:
	lists.lisp 
Log Message:
Have make-list check that the list-size is an integer.


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/05/06 20:30:54	1.18
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2007/02/20 23:11:44	1.19
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.18 2006/05/06 20:30:54 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.19 2007/02/20 23:11:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -232,6 +232,7 @@
 	  (setf (cdr new-tail) (cons (pop more-objects) nil)))))))
 
 (defun make-list (size &key initial-element)
+  (check-type size positive-fixnum)
   (do ((list nil (cons initial-element list))
        (c size (1- c)))
       ((<= c 0) list)))



From ffjeld at common-lisp.net  Thu Feb 22 20:27:31 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 15:27:31 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222202731.D01685538B@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8464

Modified Files:
	lists.lisp 
Log Message:
Tweaked make-list.


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2007/02/20 23:11:44	1.19
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2007/02/22 20:27:31	1.20
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.19 2007/02/20 23:11:44 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.20 2007/02/22 20:27:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -232,10 +232,10 @@
 	  (setf (cdr new-tail) (cons (pop more-objects) nil)))))))
 
 (defun make-list (size &key initial-element)
-  (check-type size positive-fixnum)
   (do ((list nil (cons initial-element list))
-       (c size (1- c)))
-      ((<= c 0) list)))
+       (c (check-the positive-fixnum size) (1- c)))
+      ((<= c 0) list)
+    (declare (positive-fixnum c))))
 
 (defun getf (plist indicator &optional default)
   (do ((p plist (cddr p)))



From ffjeld at common-lisp.net  Thu Feb 22 20:28:37 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 15:28:37 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222202837.CFEB8586A9@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8518

Modified Files:
	lists.lisp 
Log Message:
Removed dead comment.


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2007/02/22 20:27:31	1.20
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2007/02/22 20:28:37	1.21
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.20 2007/02/22 20:27:31 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.21 2007/02/22 20:28:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -243,9 +243,6 @@
     (when (eq indicator (car p))
       (return (cadr p)))))
 
-;;;(defun (setf getf) (value plist indicator &optional default)
-;;;  (error "Must be implemented as a macro.."))
-
 (defsetf getf (plist indicator &optional default) (new-value)
   `(do ((p ,plist (cddr p)))
        ((null p)



From ffjeld at common-lisp.net  Thu Feb 22 21:00:22 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 16:00:22 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070222210022.197DE72086@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed up layout-program and related functions a bit. Removed remnants
of old &key parsing strategy.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/20 21:57:13	1.177
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/22 21:00:21	1.178
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.177 2007/02/20 21:57:13 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1484,7 +1484,7 @@
        (new-program nil))
       ((endp pc)
        (assert (not pending-subs) ()
-	 "pending subs: ~S" pending-subs)
+	 "pending sub-programs: ~S" pending-subs)
        (nreverse new-program))
     (let ((i (pop pc)))
       (multiple-value-bind (sub-prg sub-opts)
@@ -2605,15 +2605,11 @@
 (defclass supplied-p-function-argument (function-argument) ())
 
 (defclass rest-function-argument (positional-function-argument) ())
-(defclass hidden-rest-function-argument (rest-function-argument) ())
 
 (defclass keyword-function-argument (non-required-function-argument)
   ((keyword-name
     :initarg :keyword-name
-    :reader keyword-function-argument-keyword-name)
-   (rest-var-name
-    :initarg :rest-var-name
-    :reader keyword-function-argument-rest-var-name)))
+    :reader keyword-function-argument-keyword-name)))
 
 (defclass dynamic-binding (variable-binding) ())
 
@@ -2745,25 +2741,26 @@
 ;;;
 
 
-(defun instruction-sub-program (instruction)
-  "When an instruction contains a sub-program, return that program, and 
-the sub-program options (&optional label) as secondary value."
-  (and (consp instruction)
-       (consp (second instruction))
-       (symbolp (car (second instruction)))
-       (string= 'quote (car (second instruction)))
-       (let ((x (second (second instruction))))
-	 (and (consp x)
-	      (eq :sub-program (car x))
-	      (values (cddr x)
-		      (second x))))))
-
 (defun ignore-instruction-prefixes (instruction)
   (if (and (consp instruction)
 	   (listp (car instruction)))
       (cdr instruction)
     instruction))
 
+(defun instruction-sub-program (instruction)
+  "When an instruction contains a sub-program, return that program, and 
+the sub-program options (&optional label) as secondary value."
+  (let ((instruction (ignore-instruction-prefixes instruction)))
+    (and (consp instruction)
+	 (consp (second instruction))
+	 (symbolp (car (second instruction)))
+	 (string= 'quote (car (second instruction)))
+	 (let ((x (second (second instruction))))
+	   (and (consp x)
+		(eq :sub-program (car x))
+		(values (cddr x)
+			(second x)))))))
+
 (defun instruction-is (instruction &optional operator)
   (and (listp instruction)
        (if (member (car instruction) '(:globally :locally))
@@ -3205,7 +3202,6 @@
 								     (binding-env binding) nil)
 						     (movitz-env-get variable 'ignorable nil
 								     (binding-env binding) nil)
-						     (typep binding 'hidden-rest-function-argument)
 						     (third (gethash binding var-counts)))
 					   (warn "Unused variable: ~S"
 						 (binding-name binding))))
@@ -4410,11 +4406,6 @@
 	    (movitz-env-add-binding env (make-instance 'rest-function-argument
 				       :name formal
 				       :argnum (post-incf arg-pos)))))
-;;;	(when key-vars-p
-;;;	  ;; We need to check at run-time whether keyword checking is supressed or not.
-;;;	  (setf (allow-other-keys-var env)
-;;;	    (movitz-env-add-binding env (make-instance 'located-binding
-;;;					  :name (gensym "allow-other-keys-var-")))))
 	(when key-vars-p
 	  (setf (key-vars-p env) t)
 	  (when (>= 1 (rest-args-position env))
@@ -4436,28 +4427,16 @@
 	      (setf (movitz-env-get name 'ignore nil env) t))))
 	(setf (key-vars env)
 	  (loop for spec in key-vars
-	      with rest-var-name =
-		(or rest-var
-		    (and key-vars
-			 (let ((name (gensym "hidden-rest-var-")))
-			   (movitz-env-add-binding env (make-instance 'hidden-rest-function-argument
-							 :name name
-							 :argnum (post-incf arg-pos)))
-			   name)))
 	      collect
 		(multiple-value-bind (formal keyword-name init-form supplied-p)
 		    (decode-keyword-formal spec)
-		  (let ((formal
-			 (shadow-when-special formal env))
-			(supplied-p-parameter
-			 (or supplied-p
-			     #+ignore (gensym "supplied-p-"))))
+		  (let ((formal (shadow-when-special formal env))
+			(supplied-p-parameter supplied-p))
 		    (movitz-env-add-binding env (make-instance 'keyword-function-argument
 						  :name formal
 						  'init-form init-form
 						  'supplied-p-var supplied-p-parameter
-						  :keyword-name keyword-name
-						  :rest-var-name rest-var-name))
+						  :keyword-name keyword-name))
 		    (when supplied-p-parameter
 		      (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
 						    :name (shadow-when-special supplied-p-parameter env))))
@@ -4830,12 +4809,6 @@
 	(optional-vars (optional-vars env))
 	(rest-var (rest-var env))
 	(key-vars (key-vars env)))
-    (when (and (not rest-var)
-	       key-vars
-	       (not (= 1 (length key-vars))))
-      (setf rest-var
-	(keyword-function-argument-rest-var-name
-	 (movitz-binding (decode-keyword-formal (first key-vars)) env))))
     (values
      (append
       (loop for optional in optional-vars
@@ -6753,9 +6726,8 @@
 	 (cond
 	  ((typep binding 'rest-function-argument)
 	   (assert (eq :edx init-with-register))
-	   (assert (or (typep binding 'hidden-rest-function-argument)
-		       (movitz-env-get (binding-name binding)
-				       'dynamic-extent nil (binding-env binding)))
+	   (assert (movitz-env-get (binding-name binding)
+				   'dynamic-extent nil (binding-env binding))
 	       ()
 	     "&REST variable ~S must be dynamic-extent." (binding-name binding))
 	   (setf (need-normalized-ecx-p (find-function-env (binding-env binding)



From ffjeld at common-lisp.net  Thu Feb 22 21:02:09 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 16:02:09 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222210209.B547E100D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv13001

Modified Files:
	arrays.lisp 
Log Message:
Use :jnever assembly syntax.


--- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2006/05/05 18:14:41	1.59
+++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2007/02/22 21:02:09	1.60
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.59 2006/05/05 18:14:41 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.60 2007/02/22 21:02:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -348,7 +348,8 @@
 		   (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher
 			       ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 		   
-		   (() () '(:sub-program (unknown) (:int 100)))
+		   (:jnever '(:sub-program (unknown)
+			      (:int 100)))
 		  :u32
 		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :ecx)



From ffjeld at common-lisp.net  Thu Feb 22 21:03:10 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 16:03:10 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222210310.19943100D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv13062

Modified Files:
	basic-macros.lisp 
Log Message:
Tweak check-type compiler-macro to support retry restart.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2007/02/20 23:11:22	1.68
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2007/02/22 21:03:10	1.69
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.68 2007/02/20 23:11:22 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.69 2007/02/22 21:03:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -558,14 +558,16 @@
    (t (if (member type '(standard-gf-instance function pointer atom
 			 integer fixnum positive-fixnum cons symbol character null list
 			 string vector simple-vector vector-u8 vector-u16))
-	  `(with-inline-assembly (:returns :nothing :labels (fail))
+	  `(with-inline-assembly (:returns :nothing :labels (check-type-failed retry-check-type))
+	    retry-check-type
 	     (:compile-form (:result-mode (:boolean-branch-on-false . check-type-failed))
 			    (typep ,place ',type))
-	     (() () '(:sub-program (check-type-failed) (:int 66))))
-	#+ignore
-	`(unless (typep ,place ',type)
-	   (with-inline-assembly (:returns :non-local-exit)
-	     (:int 66)))
+	     (:jnever '(:sub-program (check-type-failed)
+			(:compile-form (:result-mode :edx) (quote ,type))
+			(:compile-form (:result-mode :ignore)
+			 (setf ,place (with-inline-assembly (:returns :eax)
+					(:int 60))))
+			(:jmp 'retry-check-type))))
 	form))))
 
 (defmacro assert (test-form &optional places datum-form &rest argument-forms)



From ffjeld at common-lisp.net  Thu Feb 22 21:03:50 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 16:03:50 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222210350.9BB0D100B@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv13103

Modified Files:
	interrupt.lisp 
Log Message:
Tweaks to exception-to-error mapping.


--- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp	2007/02/19 20:24:54	1.53
+++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp	2007/02/22 21:03:50	1.54
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.53 2007/02/19 20:24:54 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.54 2007/02/22 21:03:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -316,14 +316,22 @@
 	  ((60)
 	   ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX.
 	   (with-simple-restart (continue "Retry with a different value.")
-	     (error 'type-error :datum (dereference $eax) :expected-type (dereference $edx)))
+	     (error 'type-error
+		    :datum (dereference $eax)
+		    :expected-type (dereference $edx)))
 	   (format *query-io* "Enter a new value: ")
 	   (setf (dereference $eax) (read *query-io*)))
-	  (61 (error 'type-error :datum (dereference $eax) :expected-type 'list))
+	  (61 (error 'type-error
+		     :datum (dereference $eax)
+		     :expected-type 'list))
 	  (62 (error "Trying to save too many values: ~@Z." $ecx))
 	  (63 (error "Primitive assertion error. EIP=~@Z, ESI=~@Z." $eip $esi))
-	  (64 (error 'type-error :datum (dereference $eax) :expected-type 'integer))
-	  (65 (error 'index-out-of-range :index (dereference $ebx) (dereference $ecx)))
+	  (64 (error 'type-error
+		     :datum (dereference $eax)
+		     :expected-type 'integer))
+	  (65 (error 'index-out-of-range
+		     :index (dereference $ebx)
+		     :range (dereference $ecx)))
 	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
 		     $eip (dereference (+ dit-frame (dit-frame-index :esi)))
 		     $eax $ecx))



From ffjeld at common-lisp.net  Thu Feb 22 21:23:04 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 16:23:04 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222212304.3210319010@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv15249

Modified Files:
	cons.lisp 
Log Message:
Have tree-equal return singular value.


--- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/05/06 20:30:53	1.16
+++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2007/02/22 21:23:04	1.17
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.16 2006/05/06 20:30:53 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.17 2007/02/22 21:23:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -265,7 +265,7 @@
 (defun tree-equal (tree-1 tree-2 &key test test-not)
   (labels ((te (tree-1 tree-2 test)
 	     (if (not (consp tree-1))
-		 (funcall test tree-1 tree-2)
+		 (values (funcall test tree-1 tree-2))
 	       (if (not (consp tree-2))
 		   nil
 		 (and (te (car tree-1) (car tree-2) test)



From ffjeld at common-lisp.net  Thu Feb 22 22:11:21 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 22 Feb 2007 17:11:21 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070222221121.AD00325002@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv19944

Modified Files:
	symbols.lisp 
Log Message:
Added function remprop.


--- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp	2004/11/25 16:46:01	1.27
+++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp	2007/02/22 22:11:21	1.28
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.27 2004/11/25 16:46:01 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.28 2007/02/22 22:11:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -253,3 +253,6 @@
   (declare (ignore default))
   (setf (getf (symbol-plist symbol) indicator)
     value))
+
+(defun remprop (symbol indicator)
+  (remf (symbol-plist symbol) indicator))



From ffjeld at common-lisp.net  Mon Feb 26 18:22:27 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 13:22:27 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20070226182227.BDDFB5B12C@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv22556

Modified Files:
	eval.lisp 
Log Message:
Added trivial constantp and macro-function.


--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2005/04/20 06:53:23	1.17
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2007/02/26 18:22:27	1.18
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.17 2005/04/20 06:53:23 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.18 2007/02/26 18:22:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -444,3 +444,17 @@
   ;; What do do?
   (warn "Unknown declaration: ~S" declaration)
   (values))
+
+
+(defun constantp (form &optional environment)
+  (typecase form
+    (boolean t)
+    (keyword t)
+    (symbol nil)
+    (cons (eq 'quote (car form)))
+    (t t)))
+
+(defun macro-function (symbol &optional environment)
+  "=> function"
+  (declare (ignore symbol environment))
+  nil)



From ffjeld at common-lisp.net  Mon Feb 26 18:25:21 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 13:25:21 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070226182521.32366751B0@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
don't use keyword properties for CL symbols.


--- /project/movitz/cvsroot/movitz/special-operators.lisp	2006/04/10 11:47:14	1.55
+++ /project/movitz/cvsroot/movitz/special-operators.lisp	2007/02/26 18:25:21	1.56
@@ -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.55 2006/04/10 11:47:14 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.56 2007/02/26 18:25:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -328,7 +328,7 @@
 	(multiple-value-bind (cl-body declarations doc-string)
 	    (parse-docstring-declarations-and-body cl-macro-body 'cl:declare)
 	  (declare (ignore doc-string))
-	  (setf (movitz-env-get access-fn :setf-expander nil)
+	  (setf (movitz-env-get access-fn 'muerte::setf-expander nil)
 	    (let* ((form-formal (or wholevar (gensym)))
 		   (env-formal (or envvar (gensym)))
 		   (expander (if (null cl-lambda-list)



From ffjeld at common-lisp.net  Mon Feb 26 21:18:37 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 16:18:37 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070226211837.B4FD274181@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Refactor movitz-compile-file & friends, primarily in order to expose
new function movitz-compile-stream.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/22 21:00:21	1.178
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/26 21:18:37	1.179
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.179 2007/02/26 21:18:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1223,252 +1223,99 @@
 	      1))
      (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1)))))
 
-;;;(defun make-compiled-function-body-1rest (form funobj env top-level-p)
-;;;  (when (and (null (required-vars env))
-;;;	     (null (optional-vars env))
-;;;	     (null (key-vars env))
-;;;	     (rest-var env))
-;;;    (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map)
-;;;	(make-compiled-body form funobj env top-level-p)
-;;;      (let* ((rest-binding (movitz-binding (rest-var env) env nil))
-;;;	     (edx-location (and (edx-var env)
-;;;				(new-binding-location (edx-var env) frame-map
-;;;						      :default nil)))
-;;;	     (edx-code (when edx-location
-;;;			 `((:movl :edx (:ebp ,(stack-frame-offset edx-location)))))))
-;;;	(cond
-;;;	 ((not (new-binding-located-p rest-binding frame-map))
-;;;	  (append '(entry%1op
-;;;		    entry%2op
-;;;		    entry%3op)
-;;;		  (when use-stack-frame-p
-;;;		    +enter-stack-frame-code+)
-;;;		  '(start-stack-frame-setup)
-;;;		  (make-compiled-stack-frame-init stack-frame-size)
-;;;		  edx-code
-;;;		  code
-;;;		  (make-compiled-function-postlude funobj env use-stack-frame-p)))
-;;;	 (t ;; (new-binding-located-p rest-binding frame-map)
-;;;	  (let ((rest-location (new-binding-location rest-binding frame-map)))
-;;;	    (values (append +enter-stack-frame-code+
-;;;			    '(start-stack-frame-setup)
-;;;			    (make-compiled-stack-frame-init stack-frame-size)
-;;;			    `((:movl :edi (:ebp ,(stack-frame-offset rest-location))))
-;;;			    edx-code
-;;;			    `((:testb :cl :cl)
-;;;			      (:jz 'end-stack-frame-setup)
-;;;			      (:js '(:sub-program (normalize-ecx)
-;;;				     (:shrl 8 :ecx)
-;;;				     (:jmp 'ecx-ok)))
-;;;			      (:andl #x7f :ecx)
-;;;			      ecx-ok
-;;;			      (:xorl :edx :edx)
-;;;			      (:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))
-;;;			      (:movl :eax (:ebp ,(stack-frame-offset rest-location)))
-;;;			      (:jmp 'end-stack-frame-setup))
-;;;			    `(entry%1op
-;;;			      , at +enter-stack-frame-code+
-;;;			      ,@(make-compiled-stack-frame-init stack-frame-size)
-;;;			      , at edx-code
-;;;			      (:andl -8 :esp)
-;;;			      (:pushl :edi)
-;;;			      (:pushl :eax)
-;;;			      (:leal (:esp 1) :ecx)
-;;;			      (:movl :ecx (:ebp ,(stack-frame-offset rest-location)))
-;;;			      (:jmp 'end-stack-frame-setup))
-;;;			    `(entry%2op
-;;;			      , at +enter-stack-frame-code+
-;;;			      ,@(make-compiled-stack-frame-init stack-frame-size)
-;;;			      , at edx-code
-;;;			      (:andl -8 :esp)
-;;;			      (:pushl :edi)
-;;;			      (:pushl :ebx)
-;;;			      (:leal (:esp 1) :ecx)
-;;;			      (:pushl :ecx)
-;;;			      (:pushl :eax)
-;;;			      (:leal (:esp 1) :ecx)
-;;;			      (:movl :ecx (:ebp ,(stack-frame-offset rest-location)))
-;;;			      (:jmp 'end-stack-frame-setup))
-;;;			    '(end-stack-frame-setup)
-;;;			    code
-;;;			    (make-compiled-function-postlude funobj env t))
-;;;		    use-stack-frame-p))))))))
-		      
-;;;(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p)
-;;;  (when (and (= 1 (length (required-vars env)))
-;;;	     (= 1 (length (optional-vars env)))
-;;;	     (= 0 (length (key-vars env)))
-;;;	     (null (rest-var env)))
-;;;    (let* ((opt-var (first (optional-vars env)))
-;;;	   (opt-binding (movitz-binding opt-var env nil))
-;;;	   (req-binding (movitz-binding (first (required-vars env)) env nil))
-;;;	   (default-form (optional-function-argument-init-form opt-binding)))
-;;;      (compiler-values-bind (&code opt-default-code &producer opt-default-producer)
-;;;	  (compiler-call #'compile-form
-;;;	    :form default-form
-;;;	    :result-mode :push
-;;;	    :env env
-;;;	    :funobj funobj)
-;;;	(cond
-;;;	 ((eq 'compile-self-evaluating opt-default-producer)
-;;;	  (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map)
-;;;	      (make-compiled-body form funobj env top-level-p nil (list opt-default-code))
-;;;	    (declare (ignore use-stack-frame-p))
-;;;	    (let ((use-stack-frame-p t))
-;;;	      (cond
-;;;	       ((and (new-binding-located-p req-binding frame-map)
-;;;		     (new-binding-located-p opt-binding frame-map))
-;;;		(multiple-value-bind (eax-ebx-code eax-ebx-stack-offset)
-;;;		    (ecase (new-binding-location req-binding frame-map)
-;;;		      ;; might well be more cases here, but let's wait till they show up..
-;;;		      (:eax (values nil 0))
-;;;		      (1 (values '((:pushl :eax)) 1)))
-;;;		  ;; (warn "defc: ~S" opt-default-code)
-;;;		  (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset))
-;;;			(installed-default-code (finalize-code opt-default-code funobj env frame-map)))
-;;;		    (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2)))
-;;;				      entry%2op
-;;;				      (:pushl :ebp)
-;;;				      (:movl :esp :ebp)
-;;;				      (:pushl :esi)
-;;;				      start-stack-frame-setup
-;;;				      , at eax-ebx-code
-;;;				      ,@(if (eql (1+ eax-ebx-stack-offset)
-;;;						 (new-binding-location opt-binding frame-map))
-;;;					    (append `((:pushl :ebx))
-;;;						    (make-compiled-stack-frame-init (1- stack-init-size)))
-;;;					  (append (make-compiled-stack-frame-init stack-init-size)
-;;;						  `((:movl :ebx (:ebp ,(stack-frame-offset
-;;;									(new-binding-location opt-binding
-;;;											      frame-map)))))))
-;;;				      (:jmp 'arg-init-done)
-;;;				      entry%1op
-;;;				      (:pushl :ebp)
-;;;				      (:movl :esp :ebp)
-;;;				      (:pushl :esi)
-;;;				      , at eax-ebx-code
-;;;				      ,@(if (eql (1+ eax-ebx-stack-offset)
-;;;						 (new-binding-location opt-binding frame-map))
-;;;					    (append installed-default-code
-;;;						    (make-compiled-stack-frame-init (1- stack-init-size)))
-;;;					  (append (make-compiled-stack-frame-init stack-init-size)
-;;;						  installed-default-code
-;;;						  `((:popl (:ebp ,(stack-frame-offset
-;;;								   (new-binding-location opt-binding
-;;;											 frame-map)))))))
-;;;				      arg-init-done)
-;;;				    code
-;;;				    (make-compiled-function-postlude funobj env t))
-;;;			    use-stack-frame-p))))
-;;;	       ((and (new-binding-located-p req-binding frame-map)
-;;;		     (not (new-binding-located-p opt-binding frame-map)))
-;;;		(multiple-value-bind (eax-code eax-stack-offset)
-;;;		    (ecase (new-binding-location req-binding frame-map)
-;;;		      (:eax (values nil 0))
-;;;		      (1 (values '((:pushl :eax)) 1)))
-;;;		  (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2)))
-;;;				    ;; (:jmp 'decode-numargs)
-;;;				    entry%1op
-;;;				    entry%2op
-;;;				    (:pushl :ebp)
-;;;				    (:movl :esp :ebp)
-;;;				    (:pushl :esi))
-;;;				  eax-code
-;;;				  (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset))
-;;;				  code
-;;;				  (make-compiled-function-postlude funobj env t))
-;;;			  use-stack-frame-p)))
-;;;	       (t (warn "1-req-1-opt failed"))))))
-;;;	 (t nil))))))
 
 (defun movitz-compile-file (path &key ((:image *image*) *image*)
-				   load-priority
-				   (delete-file-p nil))
+                            load-priority
+                            (delete-file-p nil))
   (handler-bind
-      (#+sbcl (sb-ext:defconstant-uneql #'continue)
-       #+lispworks-personal-edition
-       (conditions:stack-overflow (lambda (&optional c)
-				    (declare (ignore c))
-				    (warn "Stack overflow. Skipping function ~S.~%"
-					  *compiling-function-name*)
-				    (invoke-restart 'skip-toplevel-form)))
-       #+ignore ((or error warning) (lambda (c)
-			     (declare (ignore c))
-			     (format *error-output* "~&;; In file ~S:" path))))
+      (#+sbcl (sb-ext:defconstant-uneql #'continue))
     (unwind-protect
-	(let ((*movitz-host-features* *features*)
-	      (*features* (image-movitz-features *image*)))
-	  (multiple-value-prog1
-	      (movitz-compile-file-internal path load-priority)
-	    (unless (equalp *features* (image-movitz-features *image*))
-	      (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
-	      (setf (image-movitz-features *image*) *features*))))
+         (let ((*movitz-host-features* *features*)
+               (*features* (image-movitz-features *image*)))
+           (multiple-value-prog1
+               (movitz-compile-file-internal path load-priority)
+             (unless (equalp *features* (image-movitz-features *image*))
+               (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
+               (setf (image-movitz-features *image*) *features*))))
       (when delete-file-p
 	(assert (equal (pathname-directory "/tmp/")
 		       (pathname-directory path))
-	    (path)
-	  "Refusing to delete file not in /tmp.")
+                (path)
+                "Refusing to delete file not in /tmp.")
 	(delete-file path)))))
 
-(defun movitz-compile-file-internal (path
-				     &optional (*default-load-priority*
-						(and (boundp '*default-load-priority*)
-						     (symbol-value '*default-load-priority*)
-						     (1+ (symbol-value '*default-load-priority*)))))
+(defun movitz-compile-file-internal (path &optional (*default-load-priority*
+                                                     (and (boundp '*default-load-priority*)
+                                                          (symbol-value '*default-load-priority*)
+                                                          (1+ (symbol-value '*default-load-priority*)))))
   (declare (special *default-load-priority*))
   (with-simple-restart (continue "Skip Movitz compilation of ~S." path)
     (with-retries-until-true (retry "Restart Movitz compilation of ~S." path)
-      ;; (warn "Compiling ~A.." path)
-      (let* ((muerte.cl::*compile-file-pathname* path)
-	     (*package* (find-package :muerte))
-	     (funobj (make-instance 'movitz-funobj-pass1
-		       :name (intern (format nil "~A" path) :muerte)
-		       :lambda-list (movitz-read nil)))
-	     (funobj-env (make-local-movitz-environment nil funobj
-							:type 'funobj-env
-							:declaration-context :funobj))
-	     (function-env (make-local-movitz-environment funobj-env funobj
-							  :type 'function-env
-							  :declaration-context :funobj))
-	     (file-code
-	      (with-compilation-unit ()
-     		(add-bindings-from-lambda-list () function-env)
-		(with-open-file (stream path :direction :input)
-		  (setf (funobj-env funobj) funobj-env)
-		  (loop for form = (with-movitz-syntax ()
-				     (read stream nil '#0=#:eof))
-		      until (eq form '#0#)
-		      appending
-			(with-simple-restart (skip-toplevel-form
-					      "Skip the compilation of top-level form~@[ ~A~]."
-					      (cond
-					       ((symbolp form) form)
-					       ((symbolp (car form)) (car form))))
-			  (when *compiler-verbose-p*
-			    (format *query-io* "~&Movitz Compiling ~S..~%"
-				    (cond
-				     ((symbolp form) form)
-				     ((symbolp (car form))
-				      (xsubseq form 0 2)))))
-			  (compiler-call #'compile-form
-			    :form form
-			    :funobj funobj
-			    :env function-env
-			    :top-level-p t
-			    :result-mode :ignore)))))))
-	(cond
-	 ((null file-code)
-	  (setf (image-load-time-funobjs *image*)
-	    (delete funobj (image-load-time-funobjs *image*) :key #'first))
-	  'muerte::constantly-true)
-	 (t (setf (extended-code function-env) file-code
-		  (need-normalized-ecx-p function-env) nil
-		  (function-envs funobj) (list (cons 'muerte.cl::t function-env))
-		  (funobj-env funobj) funobj-env)
-	    (make-compiled-funobj-pass2 funobj)
-	    (let ((name (funobj-name funobj)))
-	      (setf (movitz-env-named-function name) funobj)
-	      name)))))))
+      (with-open-file (stream path :direction :input)
+        (movitz-compile-stream-internal stream :path path)))))
+
+(defun movitz-compile-stream (stream &key (path "unknown-toplevel.lisp"))
+  (handler-bind
+      (#+sbcl (sb-ext:defconstant-uneql #'continue))
+    (unwind-protect
+         (let ((*movitz-host-features* *features*)
+               (*features* (image-movitz-features *image*)))
+           (multiple-value-prog1
+               (movitz-compile-stream-internal stream :path path)
+             (unless (equalp *features* (image-movitz-features *image*))
+               (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
+               (setf (image-movitz-features *image*) *features*)))))))
+
+(defun movitz-compile-stream-internal (stream &key (path "unknown-toplevel.lisp"))
+  (let* ((muerte.cl::*compile-file-pathname* path)
+         (*package* (find-package :muerte))
+         (funobj (make-instance 'movitz-funobj-pass1
+                  :name (intern (format nil "~A" path) :muerte)
+                  :lambda-list (movitz-read nil)))
+         (funobj-env (make-local-movitz-environment nil funobj
+                      :type 'funobj-env
+                      :declaration-context :funobj))
+         (function-env (make-local-movitz-environment funobj-env funobj
+                        :type 'function-env
+                        :declaration-context :funobj))
+         (file-code
+          (with-compilation-unit ()
+            (add-bindings-from-lambda-list () function-env)
+            (setf (funobj-env funobj) funobj-env)
+            (loop for form = (with-movitz-syntax ()
+                               (read stream nil '#0=#:eof))
+               until (eq form '#0#)
+               appending
+               (with-simple-restart (skip-toplevel-form
+                                     "Skip the compilation of top-level form~@[ ~A~]."
+                                     (cond
+                                       ((symbolp form) form)
+                                       ((symbolp (car form)) (car form))))
+                 (when *compiler-verbose-p*
+                   (format *query-io* "~&Movitz Compiling ~S..~%"
+                           (cond
+                             ((symbolp form) form)
+                             ((symbolp (car form))
+                              (xsubseq form 0 2)))))
+                 (compiler-call #'compile-form
+                  :form form
+                  :funobj funobj
+                  :env function-env
+                  :top-level-p t
+                  :result-mode :ignore))))))
+    (cond
+      ((null file-code)
+       (setf (image-load-time-funobjs *image*)
+             (delete funobj (image-load-time-funobjs *image*) :key #'first))
+       'muerte::constantly-true)
+      (t (setf (extended-code function-env) file-code
+               (need-normalized-ecx-p function-env) nil
+               (function-envs funobj) (list (cons 'muerte.cl::t function-env))
+               (funobj-env funobj) funobj-env)
+         (make-compiled-funobj-pass2 funobj)
+         (let ((name (funobj-name funobj)))
+           (setf (movitz-env-named-function name) funobj)
+           name)))))
 
 ;;;;
 



From ffjeld at common-lisp.net  Mon Feb 26 21:19:55 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 16:19:55 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20070226211955.3D8B332029@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Export movitz:movitz-compile-file and movitz:movitz-disassemble.


--- /project/movitz/cvsroot/movitz/packages.lisp	2005/08/26 22:50:36	1.54
+++ /project/movitz/cvsroot/movitz/packages.lisp	2007/02/26 21:19:55	1.55
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.54 2005/08/26 22:50:36 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.55 2007/02/26 21:19:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1299,6 +1299,8 @@
 	   #:movitz-subtypep
 
 	   #:movitz-compile-file
+           #:movitz-compile-stream
+           #:movitz-disassemble
 	   
 	   #:movitz-std-instance
 	   #:movitz-struct



From ffjeld at common-lisp.net  Mon Feb 26 21:32:55 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 16:32:55 -0500 (EST)
Subject: [movitz-cvs] CVS movitz/ide
Message-ID: <20070226213255.ECB88586AB@common-lisp.net>

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

Modified Files:
	ide.lisp 
Log Message:
Take advantage of movitz:movitz-compile-stream.


--- /project/movitz/cvsroot/movitz/ide/ide.lisp	2004/08/02 07:45:30	1.2
+++ /project/movitz/cvsroot/movitz/ide/ide.lisp	2007/02/26 21:32:55	1.3
@@ -14,19 +14,14 @@
 
 (in-package #:movitz.ide)
 
-(defconstant temp-source-file "/tmp/movitz-scratch.lisp"
-  "Temporary file used to implement race conditions.")
-
 (defun compile-movitz-file (filename)
   "Compile FILENAME as Movitz source."
   (movitz:movitz-compile-file filename))
 
 (defun compile-defun (source)
   "Compile the string SOURCE as Movitz source."
-  (with-open-file (s temp-source-file :direction :output
-                     :if-exists :overwrite :if-does-not-exist :create)
-    (princ source s))
-  (compile-movitz-file temp-source-file))
+  (with-input-from-string (stream source)
+    (movitz:movitz-compile-stream stream :path "movitz-ide-toplevel")))
 
 (defun dump-image (filename)
   "Dump the current image into FILENAME."
@@ -41,7 +36,7 @@
 (defun disassemble-fdefinition (symbol)
   "Return the disassembly SYMBOL's fdefinition as a string."
   (with-output-to-string (*standard-output*)
-    (movitz::movitz-disassemble symbol)))
+    (movitz:movitz-disassemble symbol)))
 
 
 ;;;; Utilities.



From ffjeld at common-lisp.net  Mon Feb 26 22:14:00 2007
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 26 Feb 2007 17:14:00 -0500 (EST)
Subject: [movitz-cvs] CVS ia-x86
Message-ID: <20070226221400.CA1C21901D@common-lisp.net>

Update of /project/movitz/cvsroot/ia-x86
In directory clnet:/tmp/cvs-serv9316

Modified Files:
	codec.lisp 
Log Message:
Have sign-extend-complex deal correctly with bytes of size 0.


--- /project/movitz/cvsroot/ia-x86/codec.lisp	2005/08/13 20:24:04	1.7
+++ /project/movitz/cvsroot/ia-x86/codec.lisp	2007/02/26 22:14:00	1.8
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu May  4 15:16:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: codec.lisp,v 1.7 2005/08/13 20:24:04 ffjeld Exp $
+;;;; $Id: codec.lisp,v 1.8 2007/02/26 22:14:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -672,10 +672,13 @@
 that byte (i.e. #c(255 1) => -1)."
   (let ((old-byte (realpart cdatum))
 	(numo (imagpart cdatum)))
-    (if (zerop (ldb (byte 1 (1- (* 8 numo))) old-byte))
-	cdatum
-      (complex (- old-byte (dpb 1 (byte 1 (* 8 numo)) 0))
-	       numo))))
+    (cond
+      ((= 0 numo)
+       0)
+      ((zerop (ldb (byte 1 (1- (* 8 numo))) old-byte))
+       cdatum)
+      (t (complex (- old-byte (dpb 1 (byte 1 (* 8 numo)) 0))
+                  numo)))))
 
 (defun sign-extend (old-byte numo)
   "Given a two's complement signed byte (where the most significant