From ffjeld at common-lisp.net  Tue Jul  6 20:35:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 06 Jul 2004 13:35:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BhwfA-00070d-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
I've been offline for a while, but working sometimes on this file.
Mostly it's about the migration to the new movitz-basic-vectors.
Date: Tue Jul  6 13:35:36 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.28 movitz/losp/muerte/arrays.lisp:1.29
--- movitz/losp/muerte/arrays.lisp:1.28	Tue Jun 29 16:21:28 2004
+++ movitz/losp/muerte/arrays.lisp	Tue Jul  6 13:35:36 2004
@@ -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.28 2004/06/29 23:21:28 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.29 2004/07/06 20:35:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -229,7 +229,7 @@
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
 		   (:declare-label-set basic-vector-dispatcher
-				       (any-t character u8 unknown
+				       (any-t character u8 u32
 					      unknown unknown unknown unknown))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
@@ -256,6 +256,11 @@
 			       ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 		   
 		   (() () '(:sub-program (unknown) (:int 100)))
+		  u32
+		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
+			  :ecx)
+		   (:call-global-constant box-u32-ecx)
+		   (:jmp 'return)
 		  u8
 		   (:movl :ebx :ecx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -265,9 +270,10 @@
 		   (:jmp 'return)
 		  character
 		   (:movl :ebx :ecx)
+		   (:movl :eax :ebx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:movl ,(movitz:tag :character) :eax)
-		   (:movb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
+		   (:movb (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :ah)
 		   (:jmp 'return)
 		  any-t
@@ -301,19 +307,19 @@
 			      (error "Index ~D out of bounds ~D."
 			       index (array-dimension vector 0)))))
 
-		     (:cmpl ,(movitz:vector-type-tag :any-t) :ecx)
-		     (:jne 'not-any-t)
-		     (:movl (:eax (:ebx 4) 2) :eax)
-		     (:jmp 'done)
-
-		    not-any-t
-		     (:cmpl ,(movitz:vector-type-tag :character) :ecx)
-		     (:jne 'not-character)
-		     (:movb (:eax :ebx 2) :bl)
-		     (:xorl :eax :eax)
-		     (:movb :bl :ah)
-		     (:movb ,(movitz::tag :character) :al) ; character
-		     (:jmp 'done)
+; 		     (:cmpl ,(movitz:vector-type-tag :any-t) :ecx)
+; 		     (:jne 'not-any-t)
+; 		     (:movl (:eax (:ebx 4) 2) :eax)
+; 		     (:jmp 'done)
+
+; 		    not-any-t
+; 		     (:cmpl ,(movitz:vector-type-tag :character) :ecx)
+; 		     (:jne 'not-character)
+; 		     (:movb (:eax :ebx 2) :bl)
+; 		     (:xorl :eax :eax)
+; 		     (:movb :bl :ah)
+; 		     (:movb ,(movitz::tag :character) :al) ; character
+; 		     (:jmp 'done)
     
 		    not-character
 		     (:cmpl ,(movitz:vector-type-tag :u8) :ecx)
@@ -363,13 +369,53 @@
 		   (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 		   (:andl #xffff :ecx)
 		   (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
-		   (:jnz 'not-a-vector)
+		   (:jnz '(:sub-program (not-an-index)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Not a vector index: ~S" index))))
+		   ;; t?
 		   (:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx)
 		   (:jne 'not-any-t-vector)
 		   (:movl :eax
 			  (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 		   (:jmp 'return)
+
 		  not-any-t-vector
+		   ;; Character?
+		   (:cmpl ,(movitz:basic-vector-type-tag :character) :ecx)
+		   (:jne 'not-character-vector)
+		   (:cmpb ,(movitz:tag :character) :al)
+		   (:jne '(:sub-program (not-a-character)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Not a character: ~S" value))))
+		   (:movl :edx :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+
+		  not-character-vector
+		   ;; u8?
+		   (:cmpl ,(movitz:basic-vector-type-tag :u8) :ecx)
+		   (:jne 'not-u8-vector)
+		   (:testl ,(logxor #xffffffff (* #xff movitz:+movitz-fixnum-factor+))
+			   :eax)
+		   (:jne '(:sub-program (not-an-u8)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Not an (unsigned-byte 8): ~S" value))))
+		   (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+		   (:movl :edx :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+
+		  not-u8-vector
+		   (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
+		   (:jne 'not-u32-vector)
+		   (:call-global-constant unbox-u32)
+		   (:movl :eax
+			  (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+
+		  not-u32-vector
 		   (:compile-form (:result-mode :ignore)
 				  (error "Not a vector: ~S" vector))
 		  return)
@@ -398,21 +444,21 @@
 		   (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx)
 		   (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
 
-		   (:cmpl ,(movitz:vector-type-tag :any-t) :edx)
-		   (:jnz 'not-any-t)
+; 		   (:cmpl ,(movitz:vector-type-tag :any-t) :edx)
+; 		   (:jnz 'not-any-t)
 
-		   (:movl :ebx (:eax (:ecx 4) 2))
-		   (:jmp 'done)
+; 		   (:movl :ebx (:eax (:ecx 4) 2))
+; 		   (:jmp 'done)
 
-		  not-any-t
-		   (:cmpl ,(movitz:vector-type-tag :character) :edx)
-		   (:jnz 'not-character)
-		   (:cmpb ,(movitz:tag :character) :bl)
-		   (:jnz '(:sub-program (not-character-value)
-			   (:compile-form (:result-mode :ignore)
-			    (error "Value not character: ~S" value))))
-		   (:movb :bh (:eax :ecx 2))
-		   (:jmp 'done)
+; 		  not-any-t
+; 		   (:cmpl ,(movitz:vector-type-tag :character) :edx)
+; 		   (:jnz 'not-character)
+; 		   (:cmpb ,(movitz:tag :character) :bl)
+; 		   (:jnz '(:sub-program (not-character-value)
+; 			   (:compile-form (:result-mode :ignore)
+; 			    (error "Value not character: ~S" value))))
+; 		   (:movb :bh (:eax :ecx 2))
+; 		   (:jmp 'done)
     
 		  not-character
 		   (:cmpl ,(movitz:vector-type-tag :u8) :edx)
@@ -503,6 +549,7 @@
 		      :eax)
 	       )))
        (do-it)))
+    #+ignore
     (old-vector
      (macrolet
 	 ((do-svref ()
@@ -559,6 +606,7 @@
 	       (:movl :eax
 		      (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))))))
        (do-it)))
+    #+ignore
     (old-vector
      (check-type simple-vector simple-vector)
      (assert (below index (vector-dimension simple-vector)))
@@ -568,11 +616,12 @@
 
 (defun char (string index)
   (check-type string string)
-  (assert (below index (vector-dimension string)))
+  (assert (below index (array-dimension string 0)))
   (memref string 2 index :character))
 
 (defun (setf char) (value string index)
-  (setf (aref string index) value))
+  (assert (below index (array-dimension string 0)))
+  (setf (memref string 2 index :character) value))
 
 (defun schar (string index)
   (check-type string string)
@@ -581,6 +630,7 @@
 
 (defun (setf schar) (value string index)
   (check-type string string)
+  (assert (below index (length string)))
   (setf (aref string index) value))
 
 (define-compiler-macro char%unsafe (string index)
@@ -677,17 +727,14 @@
      (error "Multi-dimensional arrays not supported."))
     (integer
      (cond
-      ((equal element-type 'character)
-       (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
-		       0 :unsigned-byte16)
-	   0)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
-		       0 :unsigned-byte16)
-	   dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
-		       0 :unsigned-byte16)
-	   #.(movitz:vector-type-tag :character))
+      ((eq element-type 'character)
+       (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+			 0 :lisp)
+	     dimensions)
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		       0 :unsigned-byte32)
+	   #.(movitz:basic-vector-type-tag :character))	 
 	 (check-type array string)
 	 (setf (fill-pointer array)
 	   (or fill-pointer dimensions))
@@ -701,24 +748,43 @@
 	     (setf (char array i) (elt initial-contents i)))))
 	 array))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
-		       0 :unsigned-byte16)
-	   0)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
-		       0 :unsigned-byte16)
-	   dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
-		       0 :unsigned-byte16)
-	   #.(movitz:vector-type-tag :u8))
+       (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+			 0 :lisp)
+	     dimensions)
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		       0 :unsigned-byte32)
+	   #.(movitz:basic-vector-type-tag :u8))
 	 (setf (fill-pointer array)
 	   (or fill-pointer dimensions))
 	 (cond
 	  (initial-element
+	   (check-type initial-element (unsigned-byte 8))
 	   (dotimes (i dimensions)
-	     (setf (aref array i) initial-element)))
+	     (setf (u8ref%unsafe array i) initial-element)))
 	  (initial-contents
-	   (replace array initial-contents)))
+	   (dotimes (i dimensions)
+	     (setf (u8ref%unsafe array i) (elt initial-contents i)))))
+	 array))
+      #+ignore
+      ((eq element-type :x) #+ignore (member element-type '(u32 (unsigned-byte 32)) :test #'equal)
+       (let ((array (malloc-data-words dimensions)))
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+			 0 :lisp)
+	     dimensions)
+	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		       0 :unsigned-byte32)
+	   #.(movitz:basic-vector-type-tag :u32))
+	 (setf (fill-pointer array)
+	   (or fill-pointer dimensions))
+	 (cond
+	  (initial-element
+	   ;; (check-type initial-element (unsigned-byte 32))
+	   (dotimes (i dimensions)
+	     (setf (u32ref%unsafe array i) initial-element)))
+	  (initial-contents
+	   (dotimes (i dimensions)
+	     (setf (u32ref%unsafe array i) (elt initial-contents i)))))
 	 array))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
        (let ((array (malloc-data-words dimensions)))
@@ -740,8 +806,7 @@
 	  (initial-contents
 	   (replace array initial-contents)))
 	 array))
-      (t #+ignore (eq element-type :basic)
-       (check-type dimensions (and fixnum (integer 0 *)))
+      (t (check-type dimensions (and fixnum (integer 0 *)))
 	 (let ((array (malloc-words dimensions)))
 	   (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 			 0 :lisp)
@@ -753,26 +818,6 @@
 	     (case fill-pointer
 	       ((nil t) dimensions)
 	       (t fill-pointer)))
-	   (cond
-	    (initial-contents
-	     (replace array initial-contents))
-	    (initial-element
-	     (dotimes (i dimensions)
-	       (setf (svref%unsafe array i) initial-element))))
-	   array))
-      #+ignore
-      (t (let ((array (malloc-words dimensions)))
-	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
-			 0 :unsigned-byte16)
-	     0)
-	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
-			 0 :unsigned-byte16)
-	     dimensions)
-	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
-			 0 :unsigned-byte16)
-	     #.(movitz:vector-type-tag :any-t))
-	   (setf (fill-pointer array)
-	     (or fill-pointer dimensions))
 	   (cond
 	    (initial-contents
 	     (replace array initial-contents))




From ffjeld at common-lisp.net  Tue Jul  6 21:11:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 06 Jul 2004 14:11:53 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BhxEH-0006T3-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
I've been offline for a while, but working sometimes on this file.
Mostly it's about the migration to the new movitz-basic-vectors.
Date: Tue Jul  6 14:11:53 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.23 movitz/storage-types.lisp:1.24
--- movitz/storage-types.lisp:1.23	Tue Jun 29 16:20:56 2004
+++ movitz/storage-types.lisp	Tue Jul  6 14:11:53 2004
@@ -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.23 2004/06/29 23:20:56 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.24 2004/07/06 21:11:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -462,10 +462,10 @@
 (defmethod write-binary-record ((obj movitz-basic-vector) stream)
   (flet ((write-element (type stream data)
 	   (ecase type
-;;;	     (:u8        (write-binary 'u8 stream data))
-;;;	     (:u16       (write-binary 'u16 stream data))
-;;;	     (:u32       (write-binary 'u32 stream data))
-;;;	     (:character (write-binary 'char8 stream data))
+	     (:u8        (write-binary 'u8 stream data))
+	     (:u16       (write-binary 'u16 stream data))
+	     (:u32       (write-binary 'u32 stream data))
+	     (:character (write-binary 'char8 stream data))
 	     (:any-t     (write-binary 'word stream (movitz-read-and-intern data 'word))))))
     (+ (call-next-method)		; header
        (etypecase (movitz-vector-symbolic-data obj)
@@ -593,7 +593,7 @@
 	(make-array size :initial-element (or (and initial-element-p initial-element)
 					      default-element))))
     (cond
-     ((eq et :any-t)
+     ((member et '(:any-t :character :u8 :u32))
       (when flags (break "flags: ~S" flags))
       (when (and alignment-offset (plusp alignment-offset))
 	(break "alignment: ~S" alignment-offset))
@@ -622,7 +622,7 @@
 ;; (map 'list #'make-movitz-character string)))
 
 (defun movitz-stringp (x)
-  (and (typep x 'movitz-vector)
+  (and (typep x '(or movitz-basic-vector movitz-vector))
        (eq :character (movitz-vector-element-type x))))
 
 (deftype movitz-string ()




From ffjeld at common-lisp.net  Wed Jul  7 09:42:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 02:42:37 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1Bi8wn-00063k-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
I've been offline for a while, but working sometimes on this file.
Mostly it's about the migration to the new movitz-basic-vectors.
Date: Wed Jul  7 02:42:36 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.19 movitz/losp/muerte/typep.lisp:1.20
--- movitz/losp/muerte/typep.lisp:1.19	Thu Jun 17 12:44:49 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul  7 02:42:36 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.19 2004/06/17 19:44:49 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.20 2004/07/07 09:42:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -99,9 +99,47 @@
 	 (make-vector-typep (element-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
 			   (bt:slot-offset 'movitz::movitz-vector 'movitz::type))))
+	   (let ((old-type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
+				     (byte 8 8)
+				     (movitz:tag :vector)))
+		 (type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
+				 (byte 8 8)
+				 (movitz:tag :basic-vector))))
+	     `(with-inline-assembly-case ()
+;;;		(do-case (:boolean-branch-on-false)
+;;;		  (:compile-form (:result-mode :eax) ,object)
+;;;		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+;;;		  (:testb 7 :cl)
+;;;		  (:branch-when :boolean-zf=0)
+;;;		  (:cmpw ,type-code
+;;;			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+;;;		  (:branch-when :boolean-zf=0))
+;;;		(do-case (:boolean-branch-on-true :same :labels (vector-typep-failed))
+;;;		  (:compile-form (:result-mode :eax) ,object)
+;;;		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+;;;		  (:testb 7 :cl)
+;;;		  (:jnz 'vector-typep-failed)
+;;;		  (:cmpw ,type-code
+;;;			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+;;;		  (:branch-when :boolean-zf=1)
+;;;		  vector-typep-failed)
+		(do-case (t :boolean-zf=1 :labels (vector-typep-failed))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:jnz 'vector-typep-failed)
+		  (:cmpw ,old-type-code
+			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		  (:je 'vector-typep-failed)
+		  (:cmpw ,type-code
+			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		 vector-typep-failed))))
+	 (make-basic-vector-typep (element-type)
+	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
+			   (bt:slot-offset 'movitz::movitz-vector 'movitz::type))))
 	   (let ((type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
 				 (byte 8 8)
-				 (movitz:tag :vector))))
+				 (movitz:tag :basic-vector))))
 	     `(with-inline-assembly-case ()
 		(do-case (:boolean-branch-on-false)
 		  (:compile-form (:result-mode :eax) ,object)
@@ -119,7 +157,7 @@
 		  (:cmpw ,type-code
 			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
 		  (:branch-when :boolean-zf=1)
-		  vector-typep-failed)
+		 vector-typep-failed)
 		(do-case (t :boolean-zf=1 :labels (vector-typep-failed))
 		  (:compile-form (:result-mode :eax) ,object)
 		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
@@ -127,7 +165,7 @@
 		  (:jnz 'vector-typep-failed)
 		  (:cmpw ,type-code
 			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-		  vector-typep-failed))))
+		 vector-typep-failed))))
 	 (make-function-typep (funobj-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-funobj 'movitz::funobj-type)
 			   (bt:slot-offset 'movitz::movitz-funobj 'movitz::type))))
@@ -240,9 +278,9 @@
 		((vector array)
 		 `(typep ,object '(or old-vector basic-vector)))
 		(simple-vector
-		 (make-vector-typep :any-t))
+		 (make-basic-vector-typep :any-t))
 		(string
-		 (make-vector-typep :character))
+		 (make-basic-vector-typep :character))
 		(vector-u8
 		 (make-vector-typep :u8))
 		(vector-u16




From ffjeld at common-lisp.net  Wed Jul  7 17:33:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:33:05 -0700
Subject: [movitz-cvs] CVS update: movitz/bootblock.lisp 
Message-ID: <E1BiGI5-0003Fo-00@common-lisp.net>

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

Modified Files:
	bootblock.lisp 
Log Message:
Minor edits.

Date: Wed Jul  7 10:33:04 2004
Author: ffjeld

Index: movitz/bootblock.lisp
diff -u movitz/bootblock.lisp:1.9 movitz/bootblock.lisp:1.10
--- movitz/bootblock.lisp:1.9	Thu May 20 11:25:12 2004
+++ movitz/bootblock.lisp	Wed Jul  7 10:33:04 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Oct  9 20:47:19 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: bootblock.lisp,v 1.9 2004/05/20 18:25:12 ffjeld Exp $
+;;;; $Id: bootblock.lisp,v 1.10 2004/07/07 17:33:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -186,7 +186,6 @@
 
        copy-loop
        (:decl :ecx)
-       foo
        ((:gs-override) :movl (:ebx (:ecx 4)) :edx)
        ((:gs-override) :movl :edx (:esi (:ecx 4)))
        (:jnz 'copy-loop)
@@ -196,9 +195,6 @@
        
        (:jmp 'read-loop)
        
-       ;;
-       ;; Print text to screen telling what we are about to do
-       ;;
        read-done
 
        motor-loop			; Wait for floppy motor
@@ -404,8 +400,11 @@
 							    'new-world)
 				(mkasm-loader image-size load-address call-address))
       (let* ((loader-length (+ (length bios-loader) (length protected-loader)))
-	     (bootblock (make-array 512 :element-type '(unsigned-byte 8)
-				    :fill-pointer loader-length)))
+	     (bootblock (progn
+			  (assert (<= loader-length 510) ()
+			    "Bootblock size of ~D octets is too big, max is 510!" loader-length)
+			  (make-array 512 :element-type '(unsigned-byte 8)
+				      :fill-pointer loader-length))))
 	(setf (subseq bootblock 0) bios-loader
 	      (subseq bootblock (length bios-loader)) protected-loader)
 	(loop until (zerop (mod (fill-pointer bootblock) 4))
@@ -413,9 +412,7 @@
 	(dolist (record include-records)
 	  (let ((*endian* :little-endian))
 	    (with-binary-output-to-vector (stream bootblock)
-	      (write-binary-record record stream))))
-	(assert (<= loader-length 510) ()
-	  "Bootblock size of ~D octets is too big, max is 510!" loader-length)
+	      (write-binary-record record stream))))	
 	(setf (fill-pointer bootblock) 512
 	      (subseq bootblock 510) #(#x55 #xaa)) ; bootblock signature
 	(format t "~&;; Bootblock size is ~D octets.~%" loader-length)




From ffjeld at common-lisp.net  Wed Jul  7 17:34:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:34:10 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BiGJ8-0002Z1-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Slight change in how code-vector objects are constructed.

Date: Wed Jul  7 10:34:10 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.69 movitz/compiler.lisp:1.70
--- movitz/compiler.lisp:1.69	Mon Jun 21 00:48:59 2004
+++ movitz/compiler.lisp	Wed Jul  7 10:34:09 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.69 2004/06/21 07:48:59 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.70 2004/07/07 17:34:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -108,11 +108,8 @@
 						  (case label
 						    (:nil-value (image-nil-word *image*)))))))
     (make-movitz-vector (length code-vector)
-		     :element-type 'movitz-code
-		     :flags '(:code-vector-p)
-		     :alignment 16
-		     :alignment-offset 8
-		     :initial-contents code-vector)))
+			:element-type 'movitz-code
+			:initial-contents code-vector)))
 
 (defun register-function-code-size (funobj)
   (let* ((name (movitz-print (movitz-funobj-name funobj)))
@@ -875,9 +872,7 @@
 			    :fill-pointer code-length
 			    :element-type 'movitz-code
 			    :initial-contents code-vector
-			    :flags '(:code-vector-p)
-			    :alignment 16
-			    :alignment-offset 8))))
+			    ))))
   funobj)
 
 #+ignore




From ffjeld at common-lisp.net  Wed Jul  7 17:37:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:02 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BiGLu-0006cO-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:02 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.40 movitz/image.lisp:1.41
--- movitz/image.lisp:1.40	Tue Jun 29 16:16:43 2004
+++ movitz/image.lisp	Wed Jul  7 10:37:01 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.40 2004/06/29 23:16:43 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.41 2004/07/07 17:37:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -624,7 +624,7 @@
 
 (defun class-object-offset (name)
   (let ((name (translate-program name :cl :muerte.cl)))
-    (+ (bt:slot-offset 'movitz-vector 'data)
+    (+ (bt:slot-offset 'movitz-basic-vector 'data)
        (* 4 (1+ (or (position name (image-classes-map *image*))
 		    (error "No class named ~S in class-map." name)))))))
 
@@ -678,17 +678,18 @@
 (defmethod search-image ((image symbolic-image) address)
   (loop for a downfrom (logand address -8) by 8
       until (gethash a (image-address-hash image))
-      finally (progn 
-		;; (warn "Found at ~X: ~S" a (gethash a (image-address-hash image)))
-		(return (gethash a (image-address-hash image))))))
+      finally (let ((object (gethash a (image-address-hash image))))
+		(when (<= address (+ a (sizeof object)))
+		  ;; (warn "Found at ~X: ~S" a (gethash a (image-address-hash image)))
+		  (return object)))))
 
 (defun search-image-funobj (address &optional (*image* *image*))
   (search-image-funobj-by-image *image* address))
 
 (defmethod search-image-funobj-by-image ((image symbolic-image) address)
   (let ((code-vector (search-image image (1- address))))
-    (unless (and (typep code-vector 'movitz-vector)
-		 (eq :u8 (movitz-vector-element-type code-vector)))
+    (unless (and (typep code-vector 'movitz-basic-vector)
+		 (eq :code (movitz-vector-element-type code-vector)))
       (error "Not a code-vector at #x~8,'0X: ~S" address code-vector))
     (let ((offset (- address (movitz-intern-code-vector code-vector))))
       (assert (not (minusp offset)))
@@ -710,7 +711,7 @@
 
 (defun search-primitive-function (address &optional (*image* *image*))
   (let ((code-vector (search-image *image* address)))
-    (unless (and (typep code-vector 'movitz-vector)
+    (unless (and (typep code-vector 'movitz-basic-vector)
 		 (eq :u8 (movitz-vector-element-type code-vector)))
       (error "Not a code-vector at #x~8,'0X: ~S" address code-vector))
     (format t "~&;; Code vector: #x~X" (movitz-intern code-vector))
@@ -751,11 +752,11 @@
 a cons is an offset (the car) from some other code-vector (the cdr)."
   (assert (member type '(code-vector-word code-pointer)))
   (etypecase object
-    ((or vector movitz-vector)
+    ((or vector movitz-basic-vector)
      (+ 2 (movitz-intern object)))
     ((or symbol movitz-symbol)
      (let ((primitive-code-vector (movitz-symbol-value (movitz-read object))))
-       (check-type primitive-code-vector movitz-vector)
+       (check-type primitive-code-vector movitz-basic-vector)
        (movitz-intern-code-vector primitive-code-vector type)))
     (movitz-funobj
      (movitz-intern-code-vector (movitz-funobj-code-vector object) type))
@@ -811,7 +812,7 @@
       (setf code-vector
 	(setf (movitz-symbol-value (movitz-read name))
 	  (movitz-read #()))))
-    (check-type code-vector movitz-vector)
+    (check-type code-vector movitz-basic-vector)
     code-vector))
 
 (defun create-image (&key (init-file *default-image-init-file*)
@@ -935,7 +936,7 @@
 				  :if-does-not-exist :create)
 	  (assert (file-position stream 512) () ; leave room for bootblock.
 	    "Couldn't set file-position for ~W." (pathname stream))
-	  (let* ((stack-vector (make-instance 'movitz-vector
+	  (let* ((stack-vector (make-instance 'movitz-basic-vector
 				 :num-elements #xffff
 				 :fill-pointer 0
 				 :symbolic-data nil
@@ -1053,15 +1054,14 @@
 		      (write-size (write-binary-record obj stream)))
 		  (incf total-size write-size)
 		  (typecase obj
-		    (movitz-vector
+		    (movitz-basic-vector
 		     (case (movitz-vector-element-type obj)
 		       (:character (incf strings-numof)
 				   (incf strings-size write-size))
 		       (:any-t (incf simple-vectors-numof)
 			       (incf simple-vectors-size write-size))
-		       (:u8 (when (member :code-vector-p (movitz-vector-flags obj))
-			      (incf code-vectors-numof)
-			      (incf code-vectors-size write-size)))))
+		       (:code (incf code-vectors-numof)
+			      (incf code-vectors-size write-size))))
 		    (movitz-funobj (incf funobjs-numof)
 				(incf funobjs-size write-size))
 		    (movitz-symbol (incf symbols-numof)
@@ -1500,7 +1500,7 @@
 	       (keyword (format nil ":~A" (movitz-print object)))
 	       (common-lisp (format nil "~:[~;'~]~A" quotep (movitz-print object)))
 	       (t (format nil "~:[~;'~]~A:~A" quotep package-name (movitz-print object)))))))))
-    (movitz-vector
+    (movitz-basic-vector
      (case (movitz-vector-element-type object)
        (:character (format nil "\"~A\"" (movitz-print object)))
        (t (movitz-print object))))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:06 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BiGLy-0007bl-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:06 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.24 movitz/storage-types.lisp:1.25
--- movitz/storage-types.lisp:1.24	Tue Jul  6 14:11:53 2004
+++ movitz/storage-types.lisp	Wed Jul  7 10:37:06 2004
@@ -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.24 2004/07/06 21:11:53 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.25 2004/07/07 17:37:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,7 +67,7 @@
   :other 6
   :symbol 7
   
-  :vector #x1a
+  :old-vector #x1a
   :basic-vector #x22
   :funobj #x3a
   :bignum #x4a
@@ -328,11 +328,11 @@
 
 ;;; movitz-vectors
 
-(define-binary-class movitz-vector (movitz-heap-object-other)
+(define-binary-class movitz-basic-vector (movitz-heap-object-other)
   ((type
     :binary-type other-type-byte
     :reader movitz-vector-type
-    :initform :vector)
+    :initform :basic-vector)
    (element-type
     :binary-type (define-enum movitz-vector-element-type (u8)
 		   :any-t 0
@@ -340,30 +340,28 @@
 		   :u8 2
 		   :u16 3
 		   :u32 4
-		   :bit 5)
+		   :bit 5
+		   :code 6)
     :initarg :element-type
     :reader movitz-vector-element-type)
-   (num-elements
-    :binary-type lu16
-    :initarg :num-elements
-    :reader movitz-vector-num-elements)      
-   (flags
-    :accessor movitz-vector-flags
-    :initarg :flags
-    :initform nil
-    :binary-type (define-bitfield movitz-vector-flags (u8)
-		   (((:bits) :fill-pointer-p 2
-			     :code-vector-p 3
-			     :std-instance-slots-p 4))))
-   (alignment-power
-    :binary-lisp-type u8		; align to 2^(high-nibble+3) + low-nibble
-    :initform 0
-    :initarg :alignment-power
-    :reader movitz-vector-alignment-power)
    (fill-pointer
     :binary-type lu16
     :initarg :fill-pointer
-    :accessor movitz-vector-fill-pointer)
+    :accessor movitz-vector-fill-pointer
+    :map-binary-write (lambda (x &optional type)
+			(declare (ignore type))
+			(check-type x (unsigned-byte 14))
+			(* x 4))
+    :map-binary-read (lambda (x &optional type)
+		       (declare (ignore type))
+		       (assert (zerop (mod x 4)))
+		       (truncate x 4)))
+   (num-elements
+    :binary-type word
+    :initarg :num-elements
+    :reader movitz-vector-num-elements
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed 'movitz-word-and-print)
    (data
     :binary-lisp-type :label)		; data follows physically here
    (symbolic-data
@@ -381,39 +379,8 @@
        (byte 8 8)
        (enum-value 'other-type-byte :basic-vector)))
 
-(define-binary-class movitz-basic-vector (movitz-heap-object-other)
-  ((type
-    :binary-type other-type-byte
-    :reader movitz-vector-type
-    :initform :basic-vector)
-   (element-type
-    :binary-type (define-enum movitz-vector-element-type (u8)
-		   :any-t 0
-		   :character 1
-		   :u8 2
-		   :u16 3
-		   :u32 4
-		   :bit 5)
-    :initarg :element-type
-    :reader movitz-vector-element-type)
-   (fill-pointer
-    :binary-type lu16
-    :initarg :fill-pointer
-    :accessor movitz-vector-fill-pointer)
-   (num-elements
-    :binary-type word
-    :initarg :num-elements
-    :reader movitz-vector-num-elements
-    :map-binary-write 'movitz-read-and-intern
-    :map-binary-read-delayed 'movitz-word-and-print)
-   (data
-    :binary-lisp-type :label)		; data follows physically here
-   (symbolic-data
-    :initarg :symbolic-data
-    :accessor movitz-vector-symbolic-data))
-  (:slot-align type #.+other-type-offset+))
-
 (defun movitz-type-word-size (type)
+  "What's the size of TYPE in words?"
   (truncate (sizeof (intern (symbol-name type) :movitz)) 4))
 
 (defun movitz-svref (vector index)
@@ -422,17 +389,10 @@
 (defun movitz-vector-element-type-size (element-type)
   (ecase element-type
     ((:any-t :u32) 32)
-    ((:character :u8) 8)
+    ((:character :u8 :code) 8)
     (:u16 16)
     (:bit 1)))
 
-(defmethod update-movitz-object ((movitz-vector movitz-vector) (vector vector))
-  (when (eq :any-t (movitz-vector-element-type movitz-vector))
-    (loop for i from 0 below (length vector)
-	do (setf (svref (movitz-vector-symbolic-data movitz-vector) i)
-	     (movitz-read (svref vector i)))))
-  (values))
-
 (defmethod update-movitz-object ((movitz-vector movitz-basic-vector) (vector vector))
   (when (eq :any-t (movitz-vector-element-type movitz-vector))
     (loop for i from 0 below (length vector)
@@ -440,29 +400,10 @@
 	     (movitz-read (svref vector i)))))
   (values))
 
-(defmethod write-binary-record ((obj movitz-vector) stream)
-  (flet ((write-element (type stream data)
-	   (ecase type
-	     (:u8        (write-binary 'u8 stream data))
-	     (:u16       (write-binary 'u16 stream data))
-	     (:u32       (write-binary 'u32 stream data))
-	     (:character (write-binary 'char8 stream data))
-	     (:any-t     (write-binary 'word stream (movitz-read-and-intern data 'word))))))
-    (+ (call-next-method)		; header
-       (etypecase (movitz-vector-symbolic-data obj)
-	 (list 
-	  (loop for data in (movitz-vector-symbolic-data obj)
-	      with type = (movitz-vector-element-type obj)
-	      summing (write-element type stream data)))
-	 (vector
-	  (loop for data across (movitz-vector-symbolic-data obj)
-	      with type = (movitz-vector-element-type obj)
-	      summing (write-element type stream data)))))))
-
 (defmethod write-binary-record ((obj movitz-basic-vector) stream)
   (flet ((write-element (type stream data)
 	   (ecase type
-	     (:u8        (write-binary 'u8 stream data))
+	     ((:u8 :code)(write-binary 'u8 stream data))
 	     (:u16       (write-binary 'u16 stream data))
 	     (:u32       (write-binary 'u32 stream data))
 	     (:character (write-binary 'char8 stream data))
@@ -478,28 +419,13 @@
 	      with type = (movitz-vector-element-type obj)
 	      summing (write-element type stream data)))))))
 
-(defmethod read-binary-record ((type-name (eql 'movitz-vector)) stream &key &allow-other-keys)
-  (let ((object (call-next-method)))
-    (setf (movitz-vector-symbolic-data object)
-      (loop for i from 1 to (movitz-vector-num-elements object)
-	  collecting
-	    (ecase (movitz-vector-element-type object)
-	      (:u8        (read-binary 'u8 stream))
-	      (:u16       (read-binary 'u16 stream))
-	      (:u32       (read-binary 'u32 stream))
-	      (:character (read-binary 'char8 stream))
-	      (:any-t     (let ((word (read-binary 'word stream)))
-			    (with-image-stream-position-remembered ()
-			      (movitz-word word)))))))
-    object))
-
 (defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys)
   (let ((object (call-next-method)))
     (setf (movitz-vector-symbolic-data object)
       (loop for i from 1 to (movitz-vector-num-elements object)
 	  collecting
 	    (ecase (movitz-vector-element-type object)
-	      (:u8        (read-binary 'u8 stream))
+	      ((:u8 :code)(read-binary 'u8 stream))
 	      (:u16       (read-binary 'u16 stream))
 	      (:u32       (read-binary 'u32 stream))
 	      (:character (read-binary 'char8 stream))
@@ -508,36 +434,12 @@
 			      (movitz-word word)))))))
     object))
 
-(defmethod sizeof ((object movitz-vector))
-  (+ (call-next-method)
-     (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type))
-		 (slot-value object 'num-elements))
-	      8)))
-
 (defmethod sizeof ((object movitz-basic-vector))
   (+ (call-next-method)
      (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type))
 		 (slot-value object 'num-elements))
 	      8)))
 
-(defmethod print-object ((obj movitz-vector) stream)
-  (print-unreadable-movitz-object (obj stream :type nil :identity t)
-    (case (movitz-vector-element-type obj)
-      (:character
-       (format stream "~S" (map 'string #'identity
-				(movitz-vector-symbolic-data obj))))
-      (t (format stream "[ET:~A,NE:~A] ~A"
-		 (movitz-vector-element-type obj)
-		 (movitz-vector-num-elements obj)
-		 (movitz-vector-symbolic-data obj)))))
-  obj)
-
-(defmethod movitz-storage-alignment ((obj movitz-vector))
-  (expt 2 (+ 3 (ldb (byte 4 4) (movitz-vector-alignment-power obj)))))
-
-(defmethod movitz-storage-alignment-offset ((obj movitz-vector))
-  (ldb (byte 4 0) (movitz-vector-alignment-power obj)))
-
 (defun movitz-vector-upgrade-type (type)
   (case type
     (movitz-unboxed-integer-u8
@@ -547,7 +449,7 @@
     (movitz-character
      (values :character #\null))
     (movitz-code
-     (values :u8 0))
+     (values :code 0))
     (t (values :any-t nil))))
 
 (defun make-movitz-vector (size &key (element-type 'movitz-object)
@@ -571,18 +473,6 @@
 	       (zerop (rem (log alignment 2) 1)))
       (alignment)
     "Illegal alignment: ~A." alignment)
-;;;  (cond
-;;;   ((subtypep element-type 'movitz-unboxed-integer)
-;;;    (loop for c in initial-contents
-;;;	do (assert (integerp c) ()
-;;;	     "Object ~S is not of type ~S." c element-type)))
-;;;   ((eq element-type 'movitz-code))
-;;;     (loop for c in initial-contents
-;;;	do (assert (typep c '(unsigned-byte 8)) ()
-;;;	     "Object ~S is not of type ~S." c element-type)))
-;;;   (t (loop for c in initial-contents
-;;;	  do (assert (typep c element-type) ()
-;;;	       "Object ~S is not of type ~S." c element-type))))
   (multiple-value-bind (et default-element)
       (movitz-vector-upgrade-type element-type)
     (when initial-element-p
@@ -592,28 +482,17 @@
       (setf initial-contents
 	(make-array size :initial-element (or (and initial-element-p initial-element)
 					      default-element))))
-    (cond
-     ((member et '(:any-t :character :u8 :u32))
-      (when flags (break "flags: ~S" flags))
-      (when (and alignment-offset (plusp alignment-offset))
-	(break "alignment: ~S" alignment-offset))
-      (make-instance 'movitz-basic-vector
-	:element-type et
-	:num-elements size
-	:symbolic-data initial-contents ;; sv
-	:fill-pointer (* +movitz-fixnum-factor+
-			 (if (integerp fill-pointer)
-			     fill-pointer
-			   size))))
-     (t (make-instance 'movitz-vector
-	  :element-type et
-	  :num-elements size
-	  :symbolic-data initial-contents ;; sv
-	  :flags (union flags (if fill-pointer '(:fill-pointer-p) nil))
-	  :fill-pointer (if (integerp fill-pointer) fill-pointer size)
-	  :alignment-power (dpb (- (truncate (log alignment 2)) 3)
-				(byte 4 4)
-				alignment-offset))))))
+    (assert (member et '(:any-t :character :u8 :u32 :code)))
+    (when flags (break "flags: ~S" flags))
+    (when (and alignment-offset (plusp alignment-offset))
+      (break "alignment: ~S" alignment-offset))
+    (make-instance 'movitz-basic-vector
+      :element-type et
+      :num-elements size
+      :symbolic-data initial-contents ;; sv
+      :fill-pointer (if (integerp fill-pointer)
+			fill-pointer
+		      size))))
 
 (defun make-movitz-string (string)
   (make-movitz-vector (length string)
@@ -622,7 +501,7 @@
 ;; (map 'list #'make-movitz-character string)))
 
 (defun movitz-stringp (x)
-  (and (typep x '(or movitz-basic-vector movitz-vector))
+  (and (typep x '(or movitz-basic-vector))
        (eq :character (movitz-vector-element-type x))))
 
 (deftype movitz-string ()
@@ -707,15 +586,14 @@
       :lisp-symbol name)))
 
 (defmethod print-object ((object movitz-symbol) stream)
-  ;; (check-type (slot-value object 'name) movitz-vector)
-  (print-unreadable-object (object stream :type 'movitz-symbol)
-    (typecase (movitz-symbol-name object)
-      (movitz-vector
+  (typecase (movitz-symbol-name object)
+    (movitz-basic-vector
+     (print-unreadable-object (object stream :type 'movitz-symbol)
        (format stream "|~A|"
 	       (map 'string #'identity
 		    (slot-value (slot-value object 'name) 'symbolic-data))))
-      (t (call-next-method))))
-  object)
+     object)
+    (t (call-next-method))))
 
 (defun movitz-read-and-intern-function-value (obj type)
   (assert (eq type 'word))
@@ -977,8 +855,6 @@
     :lambda-list lambda-list
     :name name))
 
-(defparameter *foo* (make-hash-table :test #'eq))
-
 ;;;
 
 (define-binary-class movitz-funobj-standard-gf (movitz-funobj)
@@ -1228,7 +1104,6 @@
 		 finally
 		   (setf (svref bucket-data pos) movitz-key
 			 (svref bucket-data (1+ pos)) movitz-value)))
-      (setf *foo* bucket-data)
       (setf (first (movitz-struct-slot-values movitz-hash)) hash-test
 	    (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data)
 	    (third (movitz-struct-slot-values movitz-hash)) hash-sxhash)
@@ -1298,7 +1173,7 @@
 	       else
 	       do (write-binary-record
 		   (make-gate-descriptor ':interrupt
-					 (+ (slot-offset 'movitz-vector 'data)
+					 (+ (slot-offset 'movitz-basic-vector 'data)
 					    (movitz-intern
 					     (find-primitive-function
 					      'muerte::default-interrupt-trampoline))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:11 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp 
Message-ID: <E1BiGM3-00086f-00@common-lisp.net>

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

Modified Files:
	malloc-init.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:11 2004
Author: ffjeld

Index: movitz/losp/lib/malloc-init.lisp
diff -u movitz/losp/lib/malloc-init.lisp:1.3 movitz/losp/lib/malloc-init.lisp:1.4
--- movitz/losp/lib/malloc-init.lisp:1.3	Wed Jun  9 16:00:57 2004
+++ movitz/losp/lib/malloc-init.lisp	Wed Jul  7 10:37:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jan  9 15:57:22 2002
 ;;;;                
-;;;; $Id: malloc-init.lisp,v 1.3 2004/06/09 23:00:57 ffjeld Exp $
+;;;; $Id: malloc-init.lisp,v 1.4 2004/07/07 17:37:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,9 +19,15 @@
 
 (in-package muerte.lib)
 
-(let ((memsize (muerte.x86-pc::memory-size))
-      (start (truncate (* 2 1024 1024) 4096))) ; XXX We really should calcucalte this..
-  ;; (format t "Memory: ~D MB.~%" memsize)
-  (muerte:malloc-initialize start (- (* memsize #x100) start)))
+(let* ((stack-vector (%run-time-context-slot 'muerte::stack-vector))
+       (kernel-end (+ (* 4 (muerte:object-location stack-vector))
+		      8 (* 4 (array-dimension stack-vector 0))))
+       (memsize (muerte.x86-pc::memory-size))
+       (start (truncate (+ kernel-end 4095) 4096)))
+  (muerte:malloc-initialize start (- (* memsize #x100) start))
+  (loop for x from (truncate kernel-end 4) below (* start 1024)
+      do (setf (memref x 0 0 :unsigned-byte32) 0))
+  ;; (format t "Memory: ~D MB. Malloc area at ~D K.~%" memsize (* start 4))
+  (values))
 
 




From ffjeld at common-lisp.net  Wed Jul  7 17:37:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BiGM8-0000LU-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:15 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.29 movitz/losp/muerte/arrays.lisp:1.30
--- movitz/losp/muerte/arrays.lisp:1.29	Tue Jul  6 13:35:36 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul  7 10:37:15 2004
@@ -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.29 2004/07/06 20:35:36 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.30 2004/07/07 17:37:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,16 +64,19 @@
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
        '(unsigned-byte 16))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-       '(unsigned-byte 32))))
+       '(unsigned-byte 32))
+    (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
+       'code)))
 
-(defmacro vector-dimension (vector)
-  `(movitz-accessor-u16 ,vector movitz-vector num-elements))
+;;;(defmacro vector-dimension (vector)
+;;;  `(movitz-accessor-u16 ,vector movitz-vector num-elements))
 
 (defun array-dimension (array axis-number)
   (etypecase array
     (basic-vector
      (assert (zerop axis-number))
      (movitz-accessor array movitz-basic-vector num-elements))
+    #+ignore
     (vector
      (assert (zerop axis-number))
      (vector-dimension array))))
@@ -83,15 +86,15 @@
   vector)
 
 
-(define-compiler-macro vector-fill-pointer (vector)
-  `(movitz-accessor-u16 ,vector movitz-vector fill-pointer)
-  #+ignore `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-	      (:compile-form (:result-mode :eax) ,vector)
-	      (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer))
-		       :ecx)))
-
-(defun vector-fill-pointer (vector)
-  (vector-fill-pointer vector))
+;;;(define-compiler-macro vector-fill-pointer (vector)
+;;;  `(movitz-accessor-u16 ,vector movitz-vector fill-pointer)
+;;;  #+ignore `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+;;;	      (:compile-form (:result-mode :eax) ,vector)
+;;;	      (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer))
+;;;		       :ecx)))
+;;;
+;;;(defun vector-fill-pointer (vector)
+;;;  (vector-fill-pointer vector))
 
 (define-compiler-macro %basic-vector-has-fill-pointer-p (vector)
   "Does the basic-vector have a fill-pointer?"
@@ -121,10 +124,7 @@
     (basic-vector
      (assert (%basic-vector-has-fill-pointer-p vector) (vector)
        "Vector has no fill-pointer.")
-     (%basic-vector-fill-pointer vector))
-    (old-vector
-     (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0
-	     :unsigned-byte16))))
+     (%basic-vector-fill-pointer vector))))
 
 
 (defun (setf fill-pointer) (new-fill-pointer vector)
@@ -148,6 +148,7 @@
 			(error "Illegal fill-pointer: ~W." new-fill-pointer))))
 	       (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer))))))
        (do-it)))
+    #+ignore
     (vector
      (assert (<= new-fill-pointer (vector-dimension vector)))
      (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0
@@ -229,8 +230,7 @@
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
 		   (:declare-label-set basic-vector-dispatcher
-				       (any-t character u8 u32
-					      unknown unknown unknown unknown))
+				       (any-t character u8 unknown u32 unknown code unknown))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 		   (:cmpb ,(movitz:tag :basic-vector) :cl)
@@ -261,7 +261,7 @@
 			  :ecx)
 		   (:call-global-constant box-u32-ecx)
 		   (:jmp 'return)
-		  u8
+		  u8 code
 		   (:movl :ebx :ecx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:movzxb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
@@ -280,73 +280,7 @@
 		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :eax)
 		  return)))
-	   (do-it)))
-	(old-vector
-	 (let ((vector array))
-	   (macrolet
-	       ((do-it ()
-		  `(with-inline-assembly (:returns :eax)
-		     (:compile-form (:result-mode :eax) vector)
-		     (:compile-form (:result-mode :ebx) index)
-		     (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		     (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-		     (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum
-		     (:andl ,(ash #x000ffff movitz:+movitz-fixnum-shift+) :ebx)
-
-		     (:testb 7 :cl)
-		     (:jnz '(:sub-program ()
-			     (:compile-form (:result-mode :ignore)
-			      (error "Not a vector: ~S" vector))))
-		
-		     (:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
-		     (:movzxw (:eax ,movitz:+other-type-offset+) :ecx)
-
-		     (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx)
-		     (:jae '(:sub-program ()
-			     (:compile-form (:result-mode :ignore)
-			      (error "Index ~D out of bounds ~D."
-			       index (array-dimension vector 0)))))
-
-; 		     (:cmpl ,(movitz:vector-type-tag :any-t) :ecx)
-; 		     (:jne 'not-any-t)
-; 		     (:movl (:eax (:ebx 4) 2) :eax)
-; 		     (:jmp 'done)
-
-; 		    not-any-t
-; 		     (:cmpl ,(movitz:vector-type-tag :character) :ecx)
-; 		     (:jne 'not-character)
-; 		     (:movb (:eax :ebx 2) :bl)
-; 		     (:xorl :eax :eax)
-; 		     (:movb :bl :ah)
-; 		     (:movb ,(movitz::tag :character) :al) ; character
-; 		     (:jmp 'done)
-    
-		    not-character
-		     (:cmpl ,(movitz:vector-type-tag :u8) :ecx)
-		     (:jne 'not-u8)
-		     (:movzxb (:eax :ebx 2) :eax) ; u8
-		     (:shll ,movitz::+movitz-fixnum-shift+ :eax)
-		     (:jmp 'done)
-    
-		    not-u8
-		     (:cmpl ,(movitz:vector-type-tag :u16) :ecx)
-		     (:jne 'not-u16)
-		     (:movzxw (:eax (:ebx 2) 2) :eax) ; u16
-		     (:jmp 'done)
-
-		    not-u16
-		     (:cmpl ,(movitz:vector-type-tag :u32) :ecx)
-		     (:jne 'not-u32)
-		     (:movl (:eax (:ebx 4) 2) :ecx) ; u32
-		     (:call-global-constant box-u32-ecx)
-		     (:jmp 'done)
-
-		    not-u32
-		     (:compile-form (:result-mode :ignore)
-				    (error "Not a vector: ~S" vector))
-
-		    done)))
-	     (do-it))))))
+	   (do-it)))))
    (t (vector &rest subscripts)
       (declare (ignore vector subscripts))
       (error "Multi-dimensional arrays not implemented."))))
@@ -401,7 +335,7 @@
 		   (:jne '(:sub-program (not-an-u8)
 			   (:compile-form (:result-mode :ignore)
 			    (error "Not an (unsigned-byte 8): ~S" value))))
-		   (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+		   (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
 		   (:movl :edx :ecx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
@@ -420,90 +354,6 @@
 				  (error "Not a vector: ~S" vector))
 		  return)
 		))
-	   (do-it)))
-	(old-vector
-	 (macrolet
-	     ((do-it ()
-		`(with-inline-assembly (:returns :ebx)
-		   (:compile-form (:result-mode :ebx) value)
-		   (:compile-form (:result-mode :eax) vector)
-
-		   (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		   (:testb 7 :cl)
-		   (:jnz '(:sub-program ()
-			   (:compile-form (:result-mode :ignore)
-			    (error "Not a vector: ~S" vector))))
-		   (:movzxw (:eax ,movitz:+other-type-offset+) :edx)
-    
-		   (:compile-form (:result-mode :ecx) index)
-		   (:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-		   (:jnz '(:sub-program () (:int 107))) ; index not fixnum
-		   (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :ecx)
-		   (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
-
-		   (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx)
-		   (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
-
-; 		   (:cmpl ,(movitz:vector-type-tag :any-t) :edx)
-; 		   (:jnz 'not-any-t)
-
-; 		   (:movl :ebx (:eax (:ecx 4) 2))
-; 		   (:jmp 'done)
-
-; 		  not-any-t
-; 		   (:cmpl ,(movitz:vector-type-tag :character) :edx)
-; 		   (:jnz 'not-character)
-; 		   (:cmpb ,(movitz:tag :character) :bl)
-; 		   (:jnz '(:sub-program (not-character-value)
-; 			   (:compile-form (:result-mode :ignore)
-; 			    (error "Value not character: ~S" value))))
-; 		   (:movb :bh (:eax :ecx 2))
-; 		   (:jmp 'done)
-    
-		  not-character
-		   (:cmpl ,(movitz:vector-type-tag :u8) :edx)
-		   (:jnz 'not-u8)
-		   (:testl ,(cl:ldb (cl:byte 32 0)
-				    (- -1 (* #xff movitz:+movitz-fixnum-factor+)))
-			   :ebx)
-		   (:jnz '(:sub-program (not-u8-value)
-			   (:compile-form (:result-mode :ignore)
-			    (error "Value not (unsigned-byte 8): ~S" value))))
-		   (:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
-		   (:movb :bl (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-		   (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx)
-		   (:jmp 'done)
-    
-    
-		  not-u8
-		   (:cmpl ,(movitz:vector-type-tag :u16) :edx)
-		   (:jnz 'not-u16)
-		   (:testl ,(ldb (byte 32 0)
-				 (- -1 (* #xffff movitz:+movitz-fixnum-factor+)))
-			   :ebx)
-		   (:jnz '(:sub-program (not-u16-value)
-			   (:compile-form (:result-mode :ignore)
-			    (error "Value not (unsigned-byte 16): ~S" value))))
-		   (:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
-		   (:movw :bx (:eax (:ecx 2) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-		   (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx)
-		   (:jmp 'done)
-
-		  not-u16
-		   (:cmpl ,(movitz:vector-type-tag :u32) :edx)
-		   (:jnz 'not-u32)
-		   ;; EBX=value, EAX=vector, ECX=index
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :edx)
-		   (:xchgl :eax :ebx)
-		   ;; EAX=value, EBX=vector, EDX=index
-		   (:call-global-constant unbox-u32)
-		   (:movl :ecx (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-		   (:movl :eax :ebx)
-		   (:jmp 'done)
-
-		  not-u32
-		   (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
-		  done)))
 	   (do-it)))))
    (t (value vector &rest subscripts)
       (declare (ignore value vector subscripts))
@@ -548,39 +398,7 @@
 	       (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 		      :eax)
 	       )))
-       (do-it)))
-    #+ignore
-    (old-vector
-     (macrolet
-	 ((do-svref ()
-	    `(with-inline-assembly (:returns :eax)
-	       (:compile-two-forms (:eax :ebx) simple-vector index)
-	       (:leal (:eax ,(- (movitz::tag :other))) :ecx)
-	       (:testb 7 :cl)
-	       (:jnz '(:sub-program (not-simple-vector)
-		       (:int 66)))
-	       (:cmpw ,(dpb (bt:enum-value 'movitz::movitz-vector-element-type :any-t)
-			    (byte 8 8)
-			    (movitz:tag :vector))
-		      (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-	       (:jne 'not-simple-vector)
-	       (:testb #.movitz::+movitz-fixnum-zmask+ :bl)
-	       (:jnz '(:sub-program (not-fixnum)
-		       (:int 107)))
-	       (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements))
-			:ecx)
-	       (:shll #.movitz::+movitz-fixnum-shift+ :ecx)
-	       (:xchgl :ecx :ebx)
-	       (:cmpl :ecx :ebx)
-	       (:jna '(:sub-program (index-out-of-bounds)
-		       (:int 70)))
-	       ,@(if (= 4 movitz::+movitz-fixnum-factor+)
-		     `((:movl (:eax :ecx #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data))
-			      :eax))
-		   `((:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-		     (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data))
-			    :eax))))))
-       (do-svref)))))
+       (do-it)))))
     
 
 (defun (setf svref) (value simple-vector index)
@@ -605,12 +423,7 @@
 	       (:jne 'not-basic-simple-vector)
 	       (:movl :eax
 		      (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))))))
-       (do-it)))
-    #+ignore
-    (old-vector
-     (check-type simple-vector simple-vector)
-     (assert (below index (vector-dimension simple-vector)))
-     (setf (memref simple-vector 2 index :lisp) value))))
+       (do-it)))))
 
 ;;; string accessors
 
@@ -682,7 +495,7 @@
   (check-type vector vector)
   (when (and start end)
     (assert (<= 0 start end))
-    (assert (<= end (vector-dimension vector))))
+    (assert (<= end (array-dimension vector 0))))
   (case (vector-element-type vector)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
        (values #'svref%unsafe #'(setf svref%unsafe)))
@@ -692,6 +505,8 @@
        (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
        (values #'u32ref%unsafe #'(setf u32ref%unsafe)))
+    (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
+       (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
     (t (warn "don't know about vector's element-type: ~S" vector)
        (values #'aref #'(setf aref)))))
 
@@ -719,6 +534,117 @@
 	    `(funcall%unsafe ,writer ,store-var , at args)
 	    `(funcall%unsafe ,reader , at args))))
 
+(defun make-basic-vector%character (dimensions fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      dimensions)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:basic-vector-type-tag :character))	 
+    (check-type array string)
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) dimensions)))
+    (cond
+     (initial-element
+      (check-type initial-element character)
+      (dotimes (i dimensions)
+	(setf (char array i) initial-element)))
+     (initial-contents
+      (replace array initial-contents)))
+    array))
+
+(defun make-basic-vector%u32 (dimensions fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words dimensions)))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      dimensions)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:basic-vector-type-tag :u32))
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) dimensions)))
+    (cond
+     (initial-element
+      ;; (check-type initial-element (unsigned-byte 32))
+      (dotimes (i dimensions)
+	(setf (u32ref%unsafe array i) initial-element)))
+     (initial-contents
+      (replace array initial-contents)))
+    array))
+
+(defun make-basic-vector%u8 (dimensions fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      dimensions)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:basic-vector-type-tag :u8))
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) dimensions)))
+    (cond
+     (initial-element
+      (check-type initial-element (unsigned-byte 8))
+      (dotimes (i dimensions)
+	(setf (u8ref%unsafe array i) initial-element)))
+     (initial-contents
+      (replace array initial-contents)))
+    array))
+
+(defun make-basic-vector%code (dimensions fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      dimensions)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:basic-vector-type-tag :code))
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) dimensions)))
+    (cond
+     (initial-element
+      (check-type initial-element (unsigned-byte 8))
+      (dotimes (i dimensions)
+	(setf (u8ref%unsafe array i) initial-element)))
+     (initial-contents
+      (replace array initial-contents)))
+    array))
+
+(defun make-basic-vector%t (dimensions fill-pointer initial-element initial-contents)
+  (check-type dimensions (and fixnum (integer 0 *)))
+  (let ((array (malloc-words dimensions)))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      dimensions)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte16)
+      #.(movitz:basic-vector-type-tag :any-t))
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) dimensions)))
+    (cond
+     (initial-contents
+      (replace array initial-contents))
+     (initial-element
+      (dotimes (i dimensions)
+	(setf (svref%unsafe array i) initial-element))))
+    array))
+
 (defun make-array (dimensions &key element-type initial-element initial-contents adjustable
 				   fill-pointer displaced-to displaced-index-offset)
   (declare (ignore adjustable displaced-to displaced-index-offset))
@@ -727,86 +653,17 @@
      (error "Multi-dimensional arrays not supported."))
     (integer
      (cond
+      ;; These should be replaced by subtypep sometime.
       ((eq element-type 'character)
-       (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
-			 0 :lisp)
-	     dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
-		       0 :unsigned-byte32)
-	   #.(movitz:basic-vector-type-tag :character))	 
-	 (check-type array string)
-	 (setf (fill-pointer array)
-	   (or fill-pointer dimensions))
-	 (cond
-	  (initial-element
-	   (check-type initial-element character)
-	   (dotimes (i dimensions)
-	     (setf (char array i) initial-element)))
-	  (initial-contents
-	   (dotimes (i dimensions)
-	     (setf (char array i) (elt initial-contents i)))))
-	 array))
+       (make-basic-vector%character dimensions fill-pointer initial-element initial-contents))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
-			 0 :lisp)
-	     dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
-		       0 :unsigned-byte32)
-	   #.(movitz:basic-vector-type-tag :u8))
-	 (setf (fill-pointer array)
-	   (or fill-pointer dimensions))
-	 (cond
-	  (initial-element
-	   (check-type initial-element (unsigned-byte 8))
-	   (dotimes (i dimensions)
-	     (setf (u8ref%unsafe array i) initial-element)))
-	  (initial-contents
-	   (dotimes (i dimensions)
-	     (setf (u8ref%unsafe array i) (elt initial-contents i)))))
-	 array))
-      #+ignore
-      ((eq element-type :x) #+ignore (member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (let ((array (malloc-data-words dimensions)))
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
-			 0 :lisp)
-	     dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
-		       0 :unsigned-byte32)
-	   #.(movitz:basic-vector-type-tag :u32))
-	 (setf (fill-pointer array)
-	   (or fill-pointer dimensions))
-	 (cond
-	  (initial-element
-	   ;; (check-type initial-element (unsigned-byte 32))
-	   (dotimes (i dimensions)
-	     (setf (u32ref%unsafe array i) initial-element)))
-	  (initial-contents
-	   (dotimes (i dimensions)
-	     (setf (u32ref%unsafe array i) (elt initial-contents i)))))
-	 array))
+       (make-basic-vector%u8 dimensions fill-pointer initial-element initial-contents))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (let ((array (malloc-data-words dimensions)))
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
-		       0 :unsigned-byte16)
-	   0)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
-		       0 :unsigned-byte16)
-	   dimensions)
-	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
-		       0 :unsigned-byte16)
-	   #.(movitz:vector-type-tag :u32))	 
-	 (setf (fill-pointer array)
-	   (or fill-pointer dimensions))
-	 (cond
-	  (initial-element
-	   (dotimes (i dimensions)
-	     (setf (aref array i) initial-element)))
-	  (initial-contents
-	   (replace array initial-contents)))
-	 array))
-      (t (check-type dimensions (and fixnum (integer 0 *)))
+       (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents))
+      ((eq element-type 'code)
+       (make-basic-vector%code dimensions fill-pointer initial-element initial-contents))
+      (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents)
+	 #+ignore
 	 (let ((array (malloc-words dimensions)))
 	   (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 			 0 :lisp)
@@ -839,9 +696,9 @@
 
 (defun vector-push (new-element vector)
   (check-type vector vector)
-  (let ((p (vector-fill-pointer vector)))
+  (let ((p (fill-pointer vector)))
     (declare (type (unsigned-byte 16) p))
-    (when (< p (vector-dimension vector))
+    (when (< p (array-dimension vector 0))
       (setf (aref vector p) new-element
 	    (fill-pointer vector) (1+ p))
       p)))
@@ -855,10 +712,10 @@
 (defun vector-push-extend (new-element vector &optional extension)
   (declare (ignore extension))
   (check-type vector vector)
-  (let ((p (vector-fill-pointer vector)))
+  (let ((p (fill-pointer vector)))
     (declare (type (unsigned-byte 16) p))
     (cond
-     ((< p (vector-dimension vector))
+     ((< p (array-dimension vector 0))
       (setf (aref vector p) new-element
 	    (fill-pointer vector) (1+ p)))
      (t (error "Vector-push extending not implemented yet.")))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:20 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BiGMC-0000vq-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:20 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.12 movitz/losp/muerte/inspect.lisp:1.13
--- movitz/losp/muerte/inspect.lisp:1.12	Thu Jun 17 02:49:18 2004
+++ movitz/losp/muerte/inspect.lisp	Wed Jul  7 10:37:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.12 2004/06/17 09:49:18 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.13 2004/07/07 17:37:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -245,7 +245,7 @@
 	   (+ -1 object-location
 	      #.(movitz::movitz-type-word-size :movitz-funobj)
 	      (funobj-num-constants object))))
-      ((or vector-u8 string)
+      ((or vector-u8 string code-vector)
        (<= object-location
 	   location
 	   (+ -1 object-location




From ffjeld at common-lisp.net  Wed Jul  7 17:37:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:25 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BiGMH-0001PK-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:25 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.12 movitz/losp/muerte/scavenge.lisp:1.13
--- movitz/losp/muerte/scavenge.lisp:1.12	Tue Jun 22 14:41:57 2004
+++ movitz/losp/muerte/scavenge.lisp	Wed Jul  7 10:37:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.12 2004/06/22 21:41:57 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.13 2004/07/07 17:37:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,10 +72,10 @@
 	  (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
 		 (code-vector (funobj-code-vector funobj))
 		 (num-jumpers (funobj-num-jumpers funobj)))
-	    (check-type code-vector vector-u8)
+	    (check-type code-vector code-vector)
 	    (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
 	    (let ((new-code-vector (funcall function code-vector scan)))
-	      (check-type new-code-vector vector-u8)
+	      (check-type new-code-vector code-vector)
 	      (unless (eq code-vector new-code-vector)
 		(error "Code-vector migration is not implemented.")
 		(setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2))
@@ -86,24 +86,28 @@
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location))
-	 ((or (scavenge-wide-typep x :vector
+	 ((scavenge-typep x :old-vector)
+	  (error "Scanned old-vector #x~Z at odd address #x~X." x scan))
+	 ((or (scavenge-wide-typep x :basic-vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
-	      (scavenge-wide-typep x :vector
-				   #.(bt:enum-value 'movitz:movitz-vector-element-type :character)))
+	      (scavenge-wide-typep x :basic-vector
+				   #.(bt:enum-value 'movitz:movitz-vector-element-type :character))
+	      (scavenge-wide-typep x :basic-vector
+				   #.(bt:enum-value 'movitz:movitz-vector-element-type :code)))
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
-	  (let ((len (word-upper16 x)))
-	    #+ignore (warn "scavenge at #x~X u8 vector len ~D." scan len)
+	  (let ((len (memref scan 0 1 :lisp)))
+	    ;; (warn "scavenge at #x~X u8 vector len ~D." scan len)
 	    (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
-	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
+	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
-	  (let ((len (word-upper16 x)))
+	  (let ((len (memref scan 0 1 :lisp)))
 	    (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
-	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
+	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
-	  (let ((len (word-upper16 x)))
+	  (let ((len (memref scan 0 1 :lisp)))
 	    (incf scan (1+ (logand (1+ len) -2)))))
 	 ((eq x (fixnum-word 3))
 	  (incf scan)
@@ -214,7 +218,7 @@
 							  return-delta
 							  -3 -8)))))
 		       (primitive-function (%word-offset (%run-time-context-ref offset) -2)))
-		  (check-type primitive-function vector-u8)
+		  (check-type primitive-function code-vector)
 		  (if (not (location-in-object-p primitive-function eip-location))
 		      nil
 		    primitive-function))))))))))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BiGMM-0001mL-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:30 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.24 movitz/losp/muerte/basic-macros.lisp:1.25
--- movitz/losp/muerte/basic-macros.lisp:1.24	Wed Jun  9 12:35:22 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul  7 10:37:30 2004
@@ -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.24 2004/06/09 19:35:22 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.25 2004/07/07 17:37:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -557,7 +557,7 @@
     nil)
    (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))
+			 string vector simple-vector vector-u8 vector-u16 code-vector))
 	  `(unless (typep ,place ',type)
 	     (with-inline-assembly (:returns :non-local-exit)
 	       (:int 66)))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BiGMQ-0002JU-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:34 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.20 movitz/losp/muerte/typep.lisp:1.21
--- movitz/losp/muerte/typep.lisp:1.20	Wed Jul  7 02:42:36 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul  7 10:37:34 2004
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 2000-2004,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      typep.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.20 2004/07/07 09:42:36 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.21 2004/07/07 17:37:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -95,45 +95,7 @@
 		(:jnz 'other-typep-failed)
 		(:cmpb ,(movitz:tag tag-name)
 		       (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-		other-typep-failed)))
-	 (make-vector-typep (element-type)
-	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
-			   (bt:slot-offset 'movitz::movitz-vector 'movitz::type))))
-	   (let ((old-type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
-				     (byte 8 8)
-				     (movitz:tag :vector)))
-		 (type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
-				 (byte 8 8)
-				 (movitz:tag :basic-vector))))
-	     `(with-inline-assembly-case ()
-;;;		(do-case (:boolean-branch-on-false)
-;;;		  (:compile-form (:result-mode :eax) ,object)
-;;;		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
-;;;		  (:testb 7 :cl)
-;;;		  (:branch-when :boolean-zf=0)
-;;;		  (:cmpw ,type-code
-;;;			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-;;;		  (:branch-when :boolean-zf=0))
-;;;		(do-case (:boolean-branch-on-true :same :labels (vector-typep-failed))
-;;;		  (:compile-form (:result-mode :eax) ,object)
-;;;		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
-;;;		  (:testb 7 :cl)
-;;;		  (:jnz 'vector-typep-failed)
-;;;		  (:cmpw ,type-code
-;;;			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-;;;		  (:branch-when :boolean-zf=1)
-;;;		  vector-typep-failed)
-		(do-case (t :boolean-zf=1 :labels (vector-typep-failed))
-		  (:compile-form (:result-mode :eax) ,object)
-		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
-		  (:testb 7 :cl)
-		  (:jnz 'vector-typep-failed)
-		  (:cmpw ,old-type-code
-			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-		  (:je 'vector-typep-failed)
-		  (:cmpw ,type-code
-			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
-		 vector-typep-failed))))
+	       other-typep-failed)))
 	 (make-basic-vector-typep (element-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
 			   (bt:slot-offset 'movitz::movitz-vector 'movitz::type))))
@@ -273,20 +235,20 @@
 		 (make-other-typep :funobj))
 		((basic-vector)
 		 (make-other-typep :basic-vector))
-		((old-vector)
-		 (make-other-typep :vector))
 		((vector array)
-		 `(typep ,object '(or old-vector basic-vector)))
+		 `(typep ,object 'basic-vector))
 		(simple-vector
 		 (make-basic-vector-typep :any-t))
 		(string
 		 (make-basic-vector-typep :character))
 		(vector-u8
-		 (make-vector-typep :u8))
+		 (make-basic-vector-typep :u8))
 		(vector-u16
-		 (make-vector-typep :u16))
+		 (make-basic-vector-typep :u16))
 		(vector-u32
-		 (make-vector-typep :u32))
+		 (make-basic-vector-typep :u32))
+		(code-vector
+		 (make-basic-vector-typep :code))
 		(run-time-context
 		 (make-other-typep :run-time-context))
 		(structure-object




From ffjeld at common-lisp.net  Wed Jul  7 17:37:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:38 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <E1BiGMU-0002fe-00@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:38 2004
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.12 movitz/losp/muerte/sequences.lisp:1.13
--- movitz/losp/muerte/sequences.lisp:1.12	Thu Jun 17 12:44:44 2004
+++ movitz/losp/muerte/sequences.lisp	Wed Jul  7 10:37:38 2004
@@ -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.12 2004/06/17 19:44:44 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.13 2004/07/07 17:37:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -68,8 +68,6 @@
 			:eax)
 	      basic-vector-length-ok)))
        (do-it)))
-    (old-vector
-     (vector-fill-pointer sequence))
     (list
      (do ((x sequence (cdr x))
 	  (length 0 (1+ length)))




From ffjeld at common-lisp.net  Wed Jul  7 17:37:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 10:37:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1BiGMZ-0002xG-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
These checkins more or less complete the migration to the new
basic-vector data-structure. All traces of the old vector structure
should be gone.

Date: Wed Jul  7 10:37:43 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.13 movitz/losp/muerte/functions.lisp:1.14
--- movitz/losp/muerte/functions.lisp:1.13	Thu Jun 10 12:26:33 2004
+++ movitz/losp/muerte/functions.lisp	Wed Jul  7 10:37:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.13 2004/06/10 19:26:33 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.14 2004/07/07 17:37:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -102,7 +102,7 @@
 
 (defun (setf funobj-code-vector) (code-vector funobj)
   (check-type funobj function)
-  (check-type code-vector vector-u8)
+  (check-type code-vector code-vector)
   (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)
     code-vector))
 
@@ -135,7 +135,7 @@
 (defun (setf funobj-code-vector%1op) (code-vector funobj)
   (check-type funobj function)
   (etypecase code-vector
-    (vector-u8
+    (code-vector
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
@@ -180,7 +180,7 @@
 (defun (setf funobj-code-vector%2op) (code-vector funobj)
   (check-type funobj function)
   (etypecase code-vector
-    (vector-u8
+    (code-vector
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
@@ -225,7 +225,7 @@
 (defun (setf funobj-code-vector%3op) (code-vector funobj)
   (check-type funobj function)
   (etypecase code-vector
-    (vector-u8
+    (code-vector
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
@@ -340,14 +340,14 @@
 			 lambda-list)
   (setf code-vector
     (etypecase code-vector
-      (vector-u8 code-vector)
+      (code-vector code-vector)
       (list
        (make-array (length code-vector)
-		   :element-type 'u8
+		   :element-type 'code
 		   :initial-contents code-vector))
       (vector 
        (make-array (length code-vector)
-		   :element-type 'u8
+		   :element-type 'code
 		   :initial-contents code-vector))))
   (let ((funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
 				 (length constants)))))




From ffjeld at common-lisp.net  Wed Jul  7 23:22:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 16:22:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1BiLk1-0003t2-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Fixed a really braindead bug in copy-symbol. The tag offset of a
symbol is 7, not 6, and this caused unaligned accesses and potentially
faulty copying.

Date: Wed Jul  7 16:22:17 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.14 movitz/losp/muerte/symbols.lisp:1.15
--- movitz/losp/muerte/symbols.lisp:1.14	Mon Jun 14 12:40:42 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Jul  7 16:22:16 2004
@@ -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.14 2004/06/14 19:40:42 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.15 2004/07/07 23:22:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -172,8 +172,8 @@
       (%create-symbol (symbol-name symbol))
     (let ((x (%word-offset (malloc-clumps 3) 1)))
       (dotimes (i 6)
-	(setf (memref x #.movitz:+other-type-offset+ i :lisp)
-	  (memref symbol #.movitz:+other-type-offset+ i :lisp)))
+	(setf (memref x #.(cl:- (movitz:tag :symbol)) i :lisp)
+	  (memref symbol #.(cl:- (movitz:tag :symbol)) i :lisp)))
       x)))
 
 (defun symbol-flags (symbol)




From ffjeld at common-lisp.net  Wed Jul  7 23:39:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 16:39:51 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BiM11-0003OE-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Updated los0-gc to be compatible with the new basic-vectors, and to
allow spaces of any size. This means there's no longer any hard 256 KB
heap limit, even if this GC scheme is still rather simple. I've set
the default newspace size to 2 MB. You can easily override this with
the argument to install-los0-consing during bootup.

Date: Wed Jul  7 16:39:50 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.18 movitz/losp/los0-gc.lisp:1.19
--- movitz/losp/los0-gc.lisp:1.18	Wed Jun 16 00:40:38 2004
+++ movitz/losp/los0-gc.lisp	Wed Jul  7 16:39:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.18 2004/06/16 07:40:38 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.19 2004/07/07 23:39:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,82 +18,64 @@
 
 (in-package muerte.init)
 
+(defconstant +space-size+ #xfffd)
+
 (defun make-space (location)
   "Make a space vector at a fixed location."
   (assert (evenp location))
   (macrolet ((x (index)
-	       `(memref location 0 ,index :unsigned-byte16)))
-    (setf (x 0) #x0
-	  (x 1) #xfffd
-	  (x 2) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
+	       `(memref location 0 ,index :unsigned-byte32)))
+    (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ +space-size+)
+	  (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
 			  (cl:byte 8 8)
-			  (bt:enum-value 'movitz:other-type-byte :vector))
-	  (x 3) #xfffd))
+			  (bt:enum-value 'movitz:other-type-byte :basic-vector))))
   (%word-offset location #.(movitz:tag :other)))
 
-(defmacro space-other (space)
-  `(memref ,space -6 3 :lisp))
 
 (defmacro space-fresh-pointer (space)
   `(memref ,space -6 2 :lisp))
 
-(defun allocate-space (&optional other-space)
-  (let ((space (make-array #xfffd :element-type '(unsigned-byte 32))))
-    (setf (space-fresh-pointer space) 2
-	  (space-other space) other-space)
+;;;(defmacro space-last-cons (space)
+;;;  "The location of the last cons-cell that will with in this space."
+;;;  `(memref ,space -6 3 :lisp))
+
+(defmacro space-other (space)
+  `(memref ,space -6 3 :lisp))
+
+(defun allocate-space (size &optional other-space)
+  (let ((space (make-array size :element-type '(unsigned-byte 32))))
+    (initialize-space space)
+    (setf (space-other space) other-space)
     space))
 
 (defun initialize-space (space)
-  (setf (space-fresh-pointer space) 2))
-
-(defun allocate-duo-space ()
-  (let* ((space1 (allocate-space))
-	 (space2 (allocate-space space1)))
-    (setf (space-other space1) space2)))
+  (setf (space-fresh-pointer space) 2
+;;;	(space-last-cons space) (+ (object-location space)
+;;;				   (array-dimension space 0)))
+	)
+  space)
+				   
+
+(defun allocate-duo-space (size)
+  (let* ((space1 (allocate-space size))
+	 (space2 (allocate-space size space1)))
+    (setf (space-other space1) space2)
+    space1))
 
 (defun space-cons-pointer ()
   (aref (%run-time-context-slot 'nursery-space) 0))
 
-(define-primitive-function muerte::get-cons-pointer ()
-  "Return in EAX the next object location with space for EAX words, with tag 6.
-Preserve ECX."
-  (with-inline-assembly (:returns :multiple-values)
-   retry
-    (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
-    (:je '(:sub-program ()
-	   (:int 50)))			; This must be called inside atomically.
-    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
-    (:movl (:edx 2) :ebx)
-    (:leal (:ebx :eax 4) :eax)
-    (:andl -8 :eax)
-    (:cmpl #x3fff4 :eax)
-    (:jae '(:sub-program (probe-failed)
-	    (:int 113)
-	    (:jmp 'retry)))
-    (:movl :edi (:edx :ebx 8 #.movitz:+other-type-offset+))
-    (:leal (:edx :ebx 8) :eax)
-    (:ret)))
+(defun test ()
+  (warn "install..")
+  (install-los0-consing 4)
+  (warn "nursery: ~Z, other: ~Z" 
+	(%run-time-context-slot 'muerte::nursery-space)
+	(space-other (%run-time-context-slot 'muerte::nursery-space)))
+  (warn "first cons: ~Z" (funcall 'truncate #x100000000 3))
+  (warn "second cons: ~Z" (funcall 'truncate #x100000000 3))
+  (halt-cpu)
+  (values))
 
-(define-primitive-function muerte::cons-commit ()
-  "Commit allocation of ECX/fixnum words.
-Preserve EAX and EBX."
-  (with-inline-assembly (:returns :multiple-values)
-   retry
-    (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
-    (:je '(:sub-program ()
-	   (:int 50)))			; This must be called inside atomically.
-    (:addl #.movitz:+movitz-fixnum-factor+ :ecx)
-    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
-    (:andl -8 :ecx)
-    (:addl (:edx 2) :ecx)
-    (:cmpl #x3fff4 :ecx)
-    (:ja '(:sub-program (commit-failed)
-	   (:int 113)
-	   (:jmp 'retry)))
-    (:movl :ecx (:edx 2))
-    (:leal (:edx :ecx) :ecx)
-    (:ret)))
-    
 (define-primitive-function los0-fast-cons ()
   "Allocate a cons cell from nursery-space."
   (macrolet
@@ -105,8 +87,9 @@
 			     (:edi (:edi-offset atomically-status))))
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :ecx)
-	    (:cmpl #x3fff4 :ecx)
-	    (:ja '(:sub-program (allocation-failed)
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :ecx)
+	    (:jae '(:sub-program (allocation-failed)
 		    ;; Exit thread-atomical
 		    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 			       (:edi (:edi-offset atomically-status))))
@@ -124,7 +107,54 @@
 	    (:ret))))
     (do-it)))
 
+(define-primitive-function muerte::get-cons-pointer ()
+  "Return in EAX the next object location with space for EAX words, with tag 6.
+Preserve ECX."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :multiple-values)
+	   retry
+	    (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
+	    (:je '(:sub-program ()
+		   (:int 50)))		; This must be called inside atomically.
+	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+	    (:movl (:edx 2) :ebx)
+	    (:leal (:ebx :eax 4) :eax)
+	    (:andl -8 :eax)
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :eax)
+	    (:ja '(:sub-program (probe-failed)
+		   (:int 113)
+		   (:jmp 'retry)))
+	    (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+))
+	    (:leal (:edx :ebx 8) :eax)
+	    (:ret))))
+    (do-it)))
 
+(define-primitive-function muerte::cons-commit ()
+  "Commit allocation of ECX/fixnum words.
+Preserve EAX and EBX."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :multiple-values)
+	   retry
+	    (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
+	    (:je '(:sub-program ()
+		   (:int 50)))		; This must be called inside atomically.
+	    (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+	    (:andl -8 :ecx)
+	    (:addl (:edx 2) :ecx)
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :ecx)
+	    (:ja '(:sub-program (commit-failed)
+		   (:int 113)
+		   (:jmp 'retry)))
+	    (:movl :ecx (:edx 2))
+	    (:leal (:edx :ecx) :ecx)
+	    (:ret))))
+    (do-it)))
+    
 (define-primitive-function los0-box-u32-ecx ()
   "Make u32 in ECX into a fixnum or bignum."
   (macrolet
@@ -140,8 +170,9 @@
 			     (:edi (:edi-offset atomically-status))))
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :eax)
-	    (:cmpl #x3fff4 :eax)
-	    (:jge '(:sub-program ()
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :eax)
+	    (:jae '(:sub-program ()
 		    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 			       (:edi (:edi-offset atomically-status))))
 		    (:int 113)		; This interrupt can be retried.
@@ -159,7 +190,7 @@
     (do-it)))
 
 (defun los0-malloc-clumps (clumps)
-  (check-type clumps (integer 0 16000))
+  (check-type clumps (integer 0 160000))
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :eax)
@@ -172,13 +203,14 @@
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :ecx)
 	    (:leal ((:ebx 2) :ecx) :eax)
-	    (:cmpl #x3fff4 :eax)
-	    (:jge '(:sub-program ()
-		    (:int 113)))
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :eax)
+	    (:ja '(:sub-program ()
+		   (:int 113)))
 	    (:movl :eax (:edx 2))
 	    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 			     (:edi (:edi-offset atomically-status))))
-	    (:movl #.(movitz:tag :infant-object) (:edx :ecx 6))
+	    (:movl ,(movitz:tag :infant-object) (:edx :ecx 6))
 	    (:leal (:edx :ecx 8) :eax)		
 	    (:xorl :ecx :ecx)
 	   init-loop			; Now init eax number of clumps.
@@ -190,7 +222,7 @@
     (do-it)))
 
 (defun los0-malloc-data-clumps (clumps)
-  (check-type clumps (integer 0 4000))
+  (check-type clumps (integer 0 160000))
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :eax)
@@ -203,9 +235,10 @@
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :ecx)
 	    (:leal ((:ebx 2) :ecx) :eax)
-	    (:cmpl #x3fff4 :eax)
-	    (:jge '(:sub-program ()
-		    (:int 113)))
+	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		   :eax)
+	    (:ja '(:sub-program ()
+		   (:int 113)))
 	    (:movl :eax (:edx 2))
 	    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 			     (:edi (:edi-offset atomically-status))))
@@ -214,33 +247,34 @@
 	    (:leal (:edx :ecx 8) :eax))))
     (do-it)))
 
-(defun install-los0-consing ()
-  (setf (%run-time-context-slot 'nursery-space)
-    (allocate-duo-space))
-  (setf (exception-handler 113)
-    (lambda (exception interrupt-frame)
-      (declare (ignore exception interrupt-frame))
-      (format t "~&;; Handling out-of-memory exception..")
-      (stop-and-copy)))
-  (let ((conser (symbol-value 'los0-fast-cons)))
-    (check-type conser vector)
-    (setf (%run-time-context-slot 'muerte::fast-cons)
-      conser))
-  (let ((conser (symbol-value 'los0-box-u32-ecx)))
-    (check-type conser vector)
-    (setf (%run-time-context-slot 'muerte::box-u32-ecx)
-      conser))
-  (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
-    (setf (symbol-function 'muerte:malloc-clumps)
-      (symbol-function 'los0-malloc-clumps))
-    (setf (symbol-function 'los0-malloc-clumps)
-      old-malloc))
-  (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
-    (setf (symbol-function 'muerte:malloc-data-clumps)
-      (symbol-function 'los0-malloc-data-clumps))
-    (setf (symbol-function 'los0-malloc-data-clumps)
-      old-malloc-data))
-  (values))
+(defun install-los0-consing (&optional (space-kilobytes 2048))
+  (let ((size (* space-kilobytes #x100)))
+    (setf (%run-time-context-slot 'nursery-space)
+      (allocate-duo-space size))
+    (setf (exception-handler 113)
+      (lambda (exception interrupt-frame)
+	(declare (ignore exception interrupt-frame))
+	(format t "~&;; Handling out-of-memory exception..")
+	(stop-and-copy)))
+    (let ((conser (symbol-value 'los0-fast-cons)))
+      (check-type conser vector)
+      (setf (%run-time-context-slot 'muerte::fast-cons)
+	conser))
+    (let ((conser (symbol-value 'los0-box-u32-ecx)))
+      (check-type conser vector)
+      (setf (%run-time-context-slot 'muerte::box-u32-ecx)
+	conser))
+    (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
+      (setf (symbol-function 'muerte:malloc-clumps)
+	(symbol-function 'los0-malloc-clumps))
+      (setf (symbol-function 'los0-malloc-clumps)
+	old-malloc))
+    (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
+      (setf (symbol-function 'muerte:malloc-data-clumps)
+	(symbol-function 'los0-malloc-data-clumps))
+      (setf (symbol-function 'los0-malloc-data-clumps)
+	old-malloc-data))
+    (values)))
 
 (defun install-old-consing ()
   (let ((conser (symbol-value 'muerte::fast-cons)))
@@ -333,7 +367,7 @@
 			   forward-x))))))))
 	;; Scavenge roots
 	(map-heap-words evacuator 0 (+ (malloc-buffer-start)
-						 (* 2 (malloc-cons-pointer))))
+				       (* 2 (malloc-cons-pointer))))
 	(map-stack-words evacuator (current-stack-frame))
 	;; Scan newspace, Cheney style.
 	(loop with newspace-location = (+ 2 (object-location newspace))




From ffjeld at common-lisp.net  Thu Jul  8 00:03:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 17:03:46 -0700
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1BiMOA-0001DN-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Updated recent news.

Date: Wed Jul  7 17:03:46 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.16 public_html/index.html:1.17
--- public_html/index.html:1.16	Tue Mar 30 00:22:10 2004
+++ public_html/index.html	Wed Jul  7 17:03:46 2004
@@ -13,11 +13,16 @@
   <h1>Movitz: a Common Lisp x86 development platform</h1>
  </div>
 
- <h3>Recent news</h3>
+ <h3>Most recent news</h3>
 
- <p> <i>March 30, 2004:</i> There is now GC support in Muerte, and an
- almost functional GC architecture included in the los0 image. Some
- info is also added <a href="movitz.html#GC">here</a>.
+ <p> <i>July 8, 2004:</i> The data-structure for vectors has been
+ changed. The vectors length is now represented by a fixnum, increasing
+ the maximum length from #xffff to most-positive-fixnum.
+ 
+ <p> The example GC system is changed to reflect the new vector
+ data-structure, so that the hard 256 KB limit on newspaces is no
+ more. The default size is set to 2 MB, and this newspace size is used
+ in the new <a href="files/los0.img"><tt>los0.img</tt></a>.
 
  <p> For more news, see the <a
  href="files/ChangeLog"><tt>ChangeLog</tt></a>.




From ffjeld at common-lisp.net  Thu Jul  8 00:12:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 17:12:43 -0700
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1BiMWp-0003kR-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
Minor stuff about bootloading.

Date: Wed Jul  7 17:12:43 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.7 public_html/movitz.html:1.8
--- public_html/movitz.html:1.7	Tue Apr  6 18:13:41 2004
+++ public_html/movitz.html	Wed Jul  7 17:12:43 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.7 2004/04/07 01:13:41 ffjeld Exp $
+ $Id: movitz.html,v 1.8 2004/07/08 00:12:43 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.7 2004/04/07 01:13:41 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.8 2004/07/08 00:12:43 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -42,6 +42,13 @@
 can prepare a bootable floppy something like this:
 
 <p><pre> cat grub-bootloader.img los0.img >/dev/fd0 </pre>
+
+The GRUB loader should also work on any other boot-devices it
+supports, such as a hard-drive, CD-ROM, or USB-pen. You probably need
+to look up the GRUB documentation for installation instructions. The
+file <a href="files/los0.img"><tt>los0.img</tt></a> is a <a
+href="http://www.gnu.org/software/grub/manual/multiboot/multiboot.html">
+multiboot compliant</a> kernel.
 
 <h2>Introduction</h2>
 




From ffjeld at common-lisp.net  Thu Jul  8 00:12:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 17:12:57 -0700
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1BiMX3-0003pR-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Use <tt> more.

Date: Wed Jul  7 17:12:57 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.17 public_html/index.html:1.18
--- public_html/index.html:1.17	Wed Jul  7 17:03:46 2004
+++ public_html/index.html	Wed Jul  7 17:12:57 2004
@@ -16,8 +16,9 @@
  <h3>Most recent news</h3>
 
  <p> <i>July 8, 2004:</i> The data-structure for vectors has been
- changed. The vectors length is now represented by a fixnum, increasing
- the maximum length from #xffff to most-positive-fixnum.
+ changed. The vectors length is now represented by a fixnum,
+ increasing the maximum length from <tt>#xffff</tt> to
+ <tt>most-positive-fixnum</tt>.
  
  <p> The example GC system is changed to reflect the new vector
  data-structure, so that the hard 256 KB limit on newspaces is no




From ffjeld at common-lisp.net  Thu Jul  8 00:14:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 17:14:35 -0700
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1BiMYd-0000WZ-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Set date.

Date: Wed Jul  7 17:14:35 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.18 public_html/index.html:1.19
--- public_html/index.html:1.18	Wed Jul  7 17:12:57 2004
+++ public_html/index.html	Wed Jul  7 17:14:35 2004
@@ -94,7 +94,7 @@
 
    <div class="footer">
      <a href="ffjeld (at) common-lisp (dot) net">Frode V. Fjeld</a>
-     Feb. 10, 2004.
+     July. 8, 2004.
    </div>
 
  </body>




From ffjeld at common-lisp.net  Thu Jul  8 00:16:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 07 Jul 2004 17:16:36 -0700
Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog 
Message-ID: <E1BiMaa-0003kO-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Wed Jul  7 17:16:36 2004
Author: ffjeld

Index: movitz/doc/ChangeLog
diff -u movitz/doc/ChangeLog:1.4 movitz/doc/ChangeLog:1.5
--- movitz/doc/ChangeLog:1.4	Sun Apr 18 05:33:10 2004
+++ movitz/doc/ChangeLog	Wed Jul  7 17:16:36 2004
@@ -1,3 +1,10 @@
+2004-07-08  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Migration to the new basic-vector data-structure is completed
+	(though not thoroughly debugged). The los0-gc.lisp example GC is
+	updated to reflect this, and now supports any newspace-size upto
+	2GB.
+
 2004-04-18  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* The bootloader no longer initializes the VGA subssystem, since




From ffjeld at common-lisp.net  Thu Jul  8 11:27:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:27:19 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <E1BiX3f-0001pb-00@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Improved handling of integer types.

Date: Thu Jul  8 04:27:19 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.15 movitz/compiler-types.lisp:1.16
--- movitz/compiler-types.lisp:1.15	Tue Jun 29 16:17:22 2004
+++ movitz/compiler-types.lisp	Thu Jul  8 04:27:19 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.15 2004/06/29 23:17:22 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.16 2004/07/08 11:27:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -60,7 +60,7 @@
   (multiple-value-call #'encoded-type-singleton
     (type-specifier-encode type-specifier)))
       
-;;;
+;;; A numscope is a subset of the integers.
 
 (defun make-numscope (&optional minimum maximum)
   (check-type minimum (or number null))
@@ -195,6 +195,14 @@
 					 epsilon)
 			 epsilon)))
 
+(defun numscope-equalp (range0 range1)
+  ;; Numscopes should always be kept on canonical form.
+  (equal range0 range1))
+
+(defun numscope-subsetp (range0 range1)
+  "Is range0 included in range1?"
+  (numscope-equalp range1 (numscope-union range0 range1)))
+
 (defun numscope-allp (range)
   "Does this numscope include every number?"
   (let ((x (car range)))
@@ -205,7 +213,7 @@
 ;;;
 
 (defparameter *tb-bitmap*
-    '(hash-table character function cons keyword symbol vector array integer :tail)
+    '(hash-table character function cons keyword symbol vector array :tail)
   "The union of these types must be t.")
 
 (defun basic-typep (x type)
@@ -243,11 +251,37 @@
 		     (case x
 		       (symbol (logior code (code 'keyword)))
 		       (array  (logior code (code 'vector)))
-		       ;; (number (logior code (code 'integer)))
 		       (t code)))))))
       (reduce #'logior (mapcar #'code types)
 	      :initial-value (code first-type)))))
 
+(defun type-values (codes &key integer-range members include complement)
+  ;; Members: A list of objects explicitly included in type.
+  ;; Include: A list of (non-encodable) type-specs included in type.
+  (check-type include list)
+  (check-type members list)
+  (check-type integer-range list)
+  (let ((new-intscope integer-range)
+	(new-members ()))
+    (dolist (member members)		; move integer members into integer-range
+      (let ((member (movitz-read member)))
+	(etypecase member
+	  (movitz-fixnum
+	   (setf new-intscope
+	     (numscope-union new-intscope	    
+			     (make-numscope (movitz-fixnum-value member)
+					    (movitz-fixnum-value member)))))
+	  (movitz-object
+	   (pushnew member new-members :test #'movitz-eql)))))
+    (let ((new-code (if (atom codes)
+			(type-code codes)
+		      (apply #'type-code codes))))
+      (values new-code
+	      new-intscope
+	      new-members
+	      include
+	      complement))))
+		  
 (defun encoded-type-decode (code integer-range members include complement)
   (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
 	(= mask (logand mask code)))
@@ -277,38 +311,6 @@
        (t (if (not complement)
 	      (cons 'or sub-specs)
 	    (list 'not (cons 'or sub-specs))))))))
-		  
-(defun type-values (codes &key integer-range members include complement)
-  ;; Members: A list of objects explicitly included in type.
-  ;; Include: A list of (non-encodable) type-specs included in type.
-  (check-type include list)
-  (check-type members list)
-  (check-type integer-range list)
-  (let ((new-intscope integer-range)
-	(new-members ()))
-    (dolist (member members)		; move integer members into integer-range
-      (let ((member (movitz-read member)))
-	(etypecase member
-	  (movitz-fixnum
-	   (setf new-intscope
-	     (numscope-union new-intscope	    
-			     (make-numscope (movitz-fixnum-value member)
-					    (movitz-fixnum-value member)))))
-	  (movitz-object
-	   (pushnew member new-members :test #'movitz-eql)))))
-    (let ((new-code (logior (if (atom codes)
-				(type-code codes)
-			      (apply #'type-code codes))
-			    (if (numscope-allp new-intscope)
-				(type-code 'integer)
-			      0))))
-      (values new-code
-	      (if (type-code-p 'integer new-code)
-		  (make-numscope nil nil)
-		new-intscope)
-	      new-members
-	      include
-	      complement))))
 
 (defun star-is-t (x)
   (if (eq x '*) t x))
@@ -326,13 +328,9 @@
 		((typep x 'movitz-nil)
 		 (type-code-p 'symbol code))
 		((basic-typep x 'fixnum)
-		 (or (type-code-p 'integer code)
-		     (and integer-range
-			  (numscope-memberp integer-range (movitz-fixnum-value x)))))
+		 (numscope-memberp integer-range (movitz-fixnum-value x)))
 		((basic-typep x 'bignum)
-		 (or (type-code-p 'integer code)
-		     (and integer-range
-			  (numscope-memberp integer-range (movitz-bignum-value x)))))
+		 (numscope-memberp integer-range (movitz-bignum-value x)))
 		(t (dolist (bt '(symbol character function cons hash-table vector)
 			     (error "Cant decide typep for ~S." x))
 		     (when (basic-typep x bt)
@@ -411,13 +409,9 @@
     (values code0 integer-range0 members0 include0 complement0))
    ((and (not complement0) (not complement1))
     (let* ((new-inumscope (numscope-union integer-range0 integer-range1))
-	   (new-code (logior code0 code1 (if (numscope-allp new-inumscope)
-					     (type-code 'integer)
-					   0))))
+	   (new-code (logior code0 code1)))
       (values new-code
-	      (if (type-code-p 'integer new-code)
-		  nil
-		new-inumscope)
+	      new-inumscope
 	      (remove-if (lambda (x)
 			   (or (encoded-typep nil t x code0 integer-range0 nil include0 nil)
 			       (encoded-typep nil t x code1 integer-range1 nil include1 nil)))
@@ -447,8 +441,10 @@
 	(bignum
 	 (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+))
 				     (integer ,(1+ +movitz-most-positive-fixnum+) *))))
-	((t nil cons symbol keyword function array vector integer hash-table character)
+	((t nil cons symbol keyword function array vector hash-table character)
 	 (type-values type-specifier))
+	((integer)
+	 (type-values () :integer-range (make-numscope)))
 	(null
 	 (type-values () :members '(nil)))
 	(list
@@ -574,7 +570,11 @@
    ((null include)
     (values nil t))
    (t (values nil nil))))
-      
+
+(defun encoded-integerp (code integer-range members include complement)
+  "Is the encoded-type a subset/subtype of integer?"
+  (declare (ignore integer-range))
+  (and (= 0 code) (null members) (null include) (not complement)))
 
 (defun encoded-subtypep (code0 integer-range0 members0 include0 complement0
 			 code1 integer-range1 members1 include1 complement1)
@@ -599,14 +599,18 @@
 	       (and (not all1) confident)))
 	;; type0 is t, and type1 isn't.
 	(result-is nil t))
+       ((and (encoded-integerp code0 integer-range0 members0 include0 complement0)
+	     (not complement1)
+	     (numscope-subsetp integer-range0 integer-range1))
+	;; type0 is an integer type which is included in type1.
+	(result-is t t))
        ((and (not complement0) (not complement1))
 	(dolist (st *tb-bitmap*)
 	  (when (type-code-p st code0)
 	    (unless (type-code-p st code1)
 	      (result-is nil t))))
-	(when integer-range0
-	  (unless (type-code-p 'integer code1)
-	    (result-is nil nil)))
+	(unless (numscope-subsetp integer-range0 integer-range1)
+	  (result-is nil t))
 	(dolist (m members0)
 	  (ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil)
 	    ((nil)




From ffjeld at common-lisp.net  Thu Jul  8 11:28:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:28:34 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1BiX4s-0002Pg-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added movitz-subtypep.

Date: Thu Jul  8 04:28:34 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.27 movitz/packages.lisp:1.28
--- movitz/packages.lisp:1.27	Thu Jun 17 02:49:03 2004
+++ movitz/packages.lisp	Thu Jul  8 04:28:34 2004
@@ -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.27 2004/06/17 09:49:03 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.28 2004/07/08 11:28:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1299,6 +1299,7 @@
 	   #:*default-image-init-file*
 	   #:movitz-constantp
 	   #:movitz-eval
+	   #:movitz-subtypep
 
 	   #:movitz-compile-file
 	   




From ffjeld at common-lisp.net  Thu Jul  8 11:30:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:30:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BiX6V-0005Nx-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Cleaning up some minor stuff after the migration to the new
vectors. Also, inform typep that basic-vector corresponds to
simple-arrays.

Date: Thu Jul  8 04:30:14 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.30 movitz/losp/muerte/arrays.lisp:1.31
--- movitz/losp/muerte/arrays.lisp:1.30	Wed Jul  7 10:37:15 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Jul  8 04:30:14 2004
@@ -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.30 2004/07/07 17:37:15 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.31 2004/07/08 11:30:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -68,34 +68,16 @@
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
        'code)))
 
-;;;(defmacro vector-dimension (vector)
-;;;  `(movitz-accessor-u16 ,vector movitz-vector num-elements))
-
 (defun array-dimension (array axis-number)
   (etypecase array
-    (basic-vector
-     (assert (zerop axis-number))
-     (movitz-accessor array movitz-basic-vector num-elements))
-    #+ignore
-    (vector
+    (simple-array
      (assert (zerop axis-number))
-     (vector-dimension array))))
+     (movitz-accessor array movitz-basic-vector num-elements))))
 
 (defun shrink-vector (vector new-size)
   (set-movitz-accessor-u16 vector movitz-vector num-elements new-size)
   vector)
 
-
-;;;(define-compiler-macro vector-fill-pointer (vector)
-;;;  `(movitz-accessor-u16 ,vector movitz-vector fill-pointer)
-;;;  #+ignore `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-;;;	      (:compile-form (:result-mode :eax) ,vector)
-;;;	      (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer))
-;;;		       :ecx)))
-;;;
-;;;(defun vector-fill-pointer (vector)
-;;;  (vector-fill-pointer vector))
-
 (define-compiler-macro %basic-vector-has-fill-pointer-p (vector)
   "Does the basic-vector have a fill-pointer?"
   `(with-inline-assembly (:returns :boolean-zf=1)
@@ -114,14 +96,13 @@
 
 (defun array-has-fill-pointer-p (array)
   (etypecase array
-    (basic-vector
+    (simple-array
      (%basic-vector-has-fill-pointer-p array))
-    (vector t)
     (array nil)))
   
 (defun fill-pointer (vector)
   (etypecase vector
-    (basic-vector
+    (simple-array
      (assert (%basic-vector-has-fill-pointer-p vector) (vector)
        "Vector has no fill-pointer.")
      (%basic-vector-fill-pointer vector))))
@@ -129,7 +110,7 @@
 
 (defun (setf fill-pointer) (new-fill-pointer vector)
   (etypecase vector
-    (basic-vector
+    (simple-array
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
@@ -147,13 +128,7 @@
 		       (:compile-form (:result-mode :ignore)
 			(error "Illegal fill-pointer: ~W." new-fill-pointer))))
 	       (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer))))))
-       (do-it)))
-    #+ignore
-    (vector
-     (assert (<= new-fill-pointer (vector-dimension vector)))
-     (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0
-		   :unsigned-byte16)
-       new-fill-pointer))))
+       (do-it)))))
 
 (defun vector-aref%unsafe (vector index)
   "No type-checking of <vector> or <index>."
@@ -225,7 +200,7 @@
   (numargs-case
    (2 (array index)
       (etypecase array
-	(basic-vector
+	(simple-array
 	 (macrolet
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
@@ -289,7 +264,7 @@
   (numargs-case
    (3 (value vector index)
       (etypecase vector
-	(basic-vector
+	(simple-array
 	 (macrolet
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
@@ -378,7 +353,7 @@
 
 (defun svref (simple-vector index)
   (etypecase simple-vector
-    (basic-vector
+    (simple-vector
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
@@ -403,7 +378,7 @@
 
 (defun (setf svref) (value simple-vector index)
   (etypecase simple-vector
-    (basic-vector
+    (simple-vector
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
@@ -662,26 +637,7 @@
        (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents))
       ((eq element-type 'code)
        (make-basic-vector%code dimensions fill-pointer initial-element initial-contents))
-      (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents)
-	 #+ignore
-	 (let ((array (malloc-words dimensions)))
-	   (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
-			 0 :lisp)
-	     dimensions)
-	   (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
-			 0 :unsigned-byte16)
-	     #.(movitz:basic-vector-type-tag :any-t))
-	   (setf (fill-pointer array)
-	     (case fill-pointer
-	       ((nil t) dimensions)
-	       (t fill-pointer)))
-	   (cond
-	    (initial-contents
-	     (replace array initial-contents))
-	    (initial-element
-	     (dotimes (i dimensions)
-	       (setf (svref%unsafe array i) initial-element))))
-	   array))))))
+      (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents))))))
 
 (defun vector (&rest objects)
   "=> vector"




From ffjeld at common-lisp.net  Thu Jul  8 11:30:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:30:21 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BiX6b-00067M-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Cleaning up some minor stuff after the migration to the new
vectors. Also, inform typep that basic-vector corresponds to
simple-arrays.

Date: Thu Jul  8 04:30:20 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.38 movitz/losp/muerte/integers.lisp:1.39
--- movitz/losp/muerte/integers.lisp:1.38	Fri Jun 11 16:26:38 2004
+++ movitz/losp/muerte/integers.lisp	Thu Jul  8 04:30:20 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.38 2004/06/11 23:26:38 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.39 2004/07/08 11:30:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1213,8 +1213,7 @@
 					'retry-jumper)
 				      (:edi (:edi-offset atomically-status))))
 
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
-			    :eax)	; Number of words
+		     (:leal ((:ecx 4) 4) :eax) ; Number of words
 		     (:call-global-constant get-cons-pointer) ; New bignum into EAX
 		     
 
@@ -1548,6 +1547,50 @@
   (numargs-case
    (1 (x) x)
    (2 (x y)
+      (number-double-dispatch (x y)
+	((fixnum fixnum)
+	 (with-inline-assembly (:returns :eax)
+	   (:compile-two-forms (:eax :ebx) x y)
+	   (:xorl :ebx :eax)))
+	((positive-fixnum positive-bignum)
+	 (macrolet
+	     ((do-it ()
+		`(let ((r (copy-bignum y)))
+		   (with-inline-assembly (:returns :eax)
+		     (:compile-two-forms (:eax :ecx) y x)
+		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		     (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx)))))
+	   (do-it)))
+	((positive-bignum positive-fixnum)
+	 (macrolet
+	     ((do-it ()
+		`(let ((r (copy-bignum x)))
+		   (with-inline-assembly (:returns :eax)
+		     (:compile-two-forms (:eax :ecx) r y)
+		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		     (:xorl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))))
+	   (do-it)))
+	((positive-bignum positive-bignum)
+	 (if (< (%bignum-bigits x) (%bignum-bigits y))
+	     (logior y x)
+	   (let ((r (copy-bignum x)))
+	     (macrolet
+		 ((do-it ()
+		    `(with-inline-assembly (:returns :eax)
+		       (:compile-two-forms (:eax :ebx) r y)
+		       (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+				:ecx)
+		       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
+			       ,(* -1 movitz:+movitz-fixnum-factor+))
+			      :edx)	; EDX is loop counter
+		      or-loop
+		       (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+			      :ecx)
+		       (:orl :ecx
+			     (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		       (:subl 4 :edx)
+		       (:jnc 'or-loop))))
+	       (do-it))))))
       (number-double-dispatch (x y)
 	(((eql 0) t) y)
 	((t (eql 0)) x)




From ffjeld at common-lisp.net  Thu Jul  8 11:30:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:30:31 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BiX6l-0006jq-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Cleaning up some minor stuff after the migration to the new
vectors. Also, inform typep that basic-vector corresponds to
simple-arrays.

Date: Thu Jul  8 04:30:27 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.24 movitz/losp/muerte/primitive-functions.lisp:1.25
--- movitz/losp/muerte/primitive-functions.lisp:1.24	Thu Jun 17 02:49:23 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Jul  8 04:30:26 2004
@@ -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.24 2004/06/17 09:49:23 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.25 2004/07/08 11:30:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -658,8 +658,6 @@
      (movitz-accessor object movitz-funobj-standard-gf standard-gf-class))
     (string
      (find-class 'string))
-    (basic-vector
-     (find-class 'vector))
     (vector
      (find-class 'vector))
     (function




From ffjeld at common-lisp.net  Thu Jul  8 11:30:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:30:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <E1BiX6q-0006uZ-00@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Cleaning up some minor stuff after the migration to the new
vectors. Also, inform typep that basic-vector corresponds to
simple-arrays.

Date: Thu Jul  8 04:30:36 2004
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.13 movitz/losp/muerte/sequences.lisp:1.14
--- movitz/losp/muerte/sequences.lisp:1.13	Wed Jul  7 10:37:38 2004
+++ movitz/losp/muerte/sequences.lisp	Thu Jul  8 04:30:36 2004
@@ -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.13 2004/07/07 17:37:38 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.14 2004/07/08 11:30:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,7 +55,7 @@
 
 (defun length (sequence)
   (etypecase sequence
-    (basic-vector
+    (simple-array
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)




From ffjeld at common-lisp.net  Thu Jul  8 11:30:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 04:30:42 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BiX6w-00070K-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Cleaning up some minor stuff after the migration to the new
vectors. Also, inform typep that basic-vector corresponds to
simple-arrays.

Date: Thu Jul  8 04:30:41 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.21 movitz/losp/muerte/typep.lisp:1.22
--- movitz/losp/muerte/typep.lisp:1.21	Wed Jul  7 10:37:34 2004
+++ movitz/losp/muerte/typep.lisp	Thu Jul  8 04:30:41 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.21 2004/07/07 17:37:34 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.22 2004/07/08 11:30:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -234,12 +234,13 @@
 		((function compiled-function)
 		 (make-other-typep :funobj))
 		((basic-vector)
+		 (break "Basic-vector typep?")
+		 (make-other-typep :basic-vector))
+		((vector simple-array array)
 		 (make-other-typep :basic-vector))
-		((vector array)
-		 `(typep ,object 'basic-vector))
 		(simple-vector
 		 (make-basic-vector-typep :any-t))
-		(string
+		((string simple-string)
 		 (make-basic-vector-typep :character))
 		(vector-u8
 		 (make-basic-vector-typep :u8))
@@ -262,6 +263,12 @@
 		(if deriver-function
 		    `(typep ,object ',(apply deriver-function (cdr type)))
 		  (case (car type)
+		    ((simple-array)
+		     (let ((et (cadr type)))
+		       (cond
+			((movitz:movitz-subtypep et '(unsigned-byte 8))
+			 (make-basic-vector-typep :u8))
+			(t (make-basic-vector-typep :any-t)))))
 		    ((integer)
 		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
 			 (cdr type)
@@ -383,7 +390,7 @@
 
 #+ignore
 (defun foo (x)
-  (typep x '(cons * symbol)))
+  (typep x '(simple-array (unsigned-byte 4))))
 
 (defmacro define-typep (tname lambda &body body)
   (let ((fname (format nil "~A-~A" 'typep tname)))




From ffjeld at common-lisp.net  Thu Jul  8 12:01:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 05:01:52 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BiXb6-0006uV-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Removed some dead code.

Date: Thu Jul  8 05:01:52 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.25 movitz/storage-types.lisp:1.26
--- movitz/storage-types.lisp:1.25	Wed Jul  7 10:37:06 2004
+++ movitz/storage-types.lisp	Thu Jul  8 05:01:51 2004
@@ -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.25 2004/07/07 17:37:06 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.26 2004/07/08 12:01:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -830,13 +830,6 @@
 		       "Unable to resolve jumper ~S." data)
 		     (write-binary 'u32 stream
 				   (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj)))))))))
-
-;;;(defmethod print-object ((obj movitz-funobj) stream)
-;;;  (format stream "#<MOVITZ-FUNOBJ ~<ll: ~A~> ~<const: ~A~> ~<code: ~A~>>"
-;;;	  (movitz-funobj-lambda-list obj)
-;;;	  (movitz-funobj-const-list obj)
-;;;	  (movitz-funobj-code-vector obj))
-;;;  (call-next-method))
 
 (defmethod print-object ((object movitz-funobj) stream)
   (if (not (slot-boundp object 'name))




From ffjeld at common-lisp.net  Thu Jul  8 13:38:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 06:38:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <E1BiZ6O-0000PL-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Added bit-vector #* read syntax.

Date: Thu Jul  8 06:38:16 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.4 movitz/losp/muerte/read.lisp:1.5
--- movitz/losp/muerte/read.lisp:1.4	Fri Apr 23 08:01:56 2004
+++ movitz/losp/muerte/read.lisp	Thu Jul  8 06:38:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.4 2004/04/23 15:01:56 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.5 2004/07/08 13:38:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -266,6 +266,18 @@
 		     (values (make-array (length contents-list)
 					 :initial-contents contents-list)
 			     form-end
+			     string end)))
+	      (#\* (let* ((token-end (find-token-end string :start (incf i) :end end))
+			  (bit-vector (make-array (- token-end i) :element-type 'bit)))
+		     (do ((p i (1+ p))
+			  (q 0 (1+ q)))
+			 ((>= p token-end))
+		       (case (schar string p)
+			 (#\0 (setf (aref bit-vector q) 0))
+			 (#\1 (setf (aref bit-vector q) 1))
+			 (t (error "Illegal bit-vector element: ~S" (schar string p)))))
+		     (values bit-vector
+			     token-end
 			     string end)))
 	      (#\s (multiple-value-bind (struct-form form-end)
 		       (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)




From ffjeld at common-lisp.net  Thu Jul  8 15:23:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 08:23:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Biak0-00067v-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Minor edit.

Date: Thu Jul  8 08:23:15 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.13 movitz/losp/muerte/inspect.lisp:1.14
--- movitz/losp/muerte/inspect.lisp:1.13	Wed Jul  7 10:37:20 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul  8 08:23:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.13 2004/07/07 17:37:20 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.14 2004/07/08 15:23:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -245,7 +245,7 @@
 	   (+ -1 object-location
 	      #.(movitz::movitz-type-word-size :movitz-funobj)
 	      (funobj-num-constants object))))
-      ((or vector-u8 string code-vector)
+      ((or string code-vector (simple-array (unsigned-byte 8)))
        (<= object-location
 	   location
 	   (+ -1 object-location




From ffjeld at common-lisp.net  Thu Jul  8 15:23:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 08:23:53 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1Biakb-0006Vy-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Add printing of bit-vectors.

Date: Thu Jul  8 08:23:53 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.10 movitz/losp/muerte/print.lisp:1.11
--- movitz/losp/muerte/print.lisp:1.10	Wed Jun  2 16:50:34 2004
+++ movitz/losp/muerte/print.lisp	Thu Jul  8 08:23:53 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.10 2004/06/02 23:50:34 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.11 2004/07/08 15:23:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -263,6 +263,10 @@
 		   (write-string "#:" stream))
 		 (write-symbol-name object stream))
 		(t (error "Huh?")))))
+	    (bit-vector
+	     (write-string "#*")
+	     (dotimes (i (length object))
+	       (write (aref object i) :radix nil)))
 	    (vector
 	     (let ((level *print-level*)
 		   (length *print-length*))




From ffjeld at common-lisp.net  Thu Jul  8 15:28:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 08:28:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1Biaom-0006Vg-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Added bit-vector for typep, and some type-predicate-functions.

Date: Thu Jul  8 08:28:12 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.22 movitz/losp/muerte/typep.lisp:1.23
--- movitz/losp/muerte/typep.lisp:1.22	Thu Jul  8 04:30:41 2004
+++ movitz/losp/muerte/typep.lisp	Thu Jul  8 08:28:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.22 2004/07/08 11:30:41 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.23 2004/07/08 15:28:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -242,6 +242,8 @@
 		 (make-basic-vector-typep :any-t))
 		((string simple-string)
 		 (make-basic-vector-typep :character))
+		((bit-vector simple-bit-vector)
+		 (make-basic-vector-typep :bit))
 		(vector-u8
 		 (make-basic-vector-typep :u8))
 		(vector-u16
@@ -268,6 +270,10 @@
 		       (cond
 			((movitz:movitz-subtypep et '(unsigned-byte 8))
 			 (make-basic-vector-typep :u8))
+			((movitz:movitz-subtypep et '(unsigned-byte 32))
+			 (make-basic-vector-typep :u32))
+			((movitz:movitz-subtypep et 'character)
+			 (make-basic-vector-typep :character))
 			(t (make-basic-vector-typep :any-t)))))
 		    ((integer)
 		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
@@ -482,6 +488,15 @@
 (define-simple-typep (vector vectorp) (obj)
   (typep obj 'vector))
 
+(define-simple-typep (simple-vector simple-vector-p) (obj)
+  (typep obj 'simple-vector))
+
+(define-simple-typep (simple-string simple-string-p) (obj)
+  (typep obj 'simple-string))
+
+(define-simple-typep (simple-bit-vector simple-bit-vector-p) (obj)
+  (typep obj 'simple-bit-vector))
+
 (define-simple-typep (pointer pointerp) (obj)
   (typep obj 'pointer))
 
@@ -489,7 +504,6 @@
   (and (typep x 'cons)
        (or (eq '* car) (typep (car x) car))
        (or (eq '* cdr) (typep (cdr x) cdr))))
-
 
 (define-simple-typep (atom atom) (x)
   (typep x 'atom))




From ffjeld at common-lisp.net  Thu Jul  8 15:28:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 08:28:53 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BiapR-0006yu-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Implemented bit-vectors.

Date: Thu Jul  8 08:28:52 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.31 movitz/losp/muerte/arrays.lisp:1.32
--- movitz/losp/muerte/arrays.lisp:1.31	Thu Jul  8 04:30:14 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Jul  8 08:28:52 2004
@@ -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.31 2004/07/08 11:30:14 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.32 2004/07/08 15:28:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -205,7 +205,13 @@
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
 		   (:declare-label-set basic-vector-dispatcher
-				       (any-t character u8 unknown u32 unknown code unknown))
+				       ,(print (loop with x = (make-list 8 :initial-element 'unknown)
+					    for et in '(:any-t :character :u8 :u32 :code :bit)
+					    do (setf (elt x (bt:enum-value
+							     'movitz::movitz-vector-element-type
+							     et))
+						 et)
+					    finally (return x))))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 		   (:cmpb ,(movitz:tag :basic-vector) :cl)
@@ -231,19 +237,19 @@
 			       ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 		   
 		   (() () '(:sub-program (unknown) (:int 100)))
-		  u32
+		  :u32
 		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :ecx)
 		   (:call-global-constant box-u32-ecx)
 		   (:jmp 'return)
-		  u8 code
+		  :u8 :code
 		   (:movl :ebx :ecx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:movzxb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			    :ecx)
 		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		   (:jmp 'return)
-		  character
+		  :character
 		   (:movl :ebx :ecx)
 		   (:movl :eax :ebx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -251,7 +257,16 @@
 		   (:movb (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :ah)
 		   (:jmp 'return)
-		  any-t
+		  :bit
+		   (:movl :ebx :ecx)
+		   (:movl :eax :ebx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:xorl :eax :eax)
+		   (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jnc 'return)
+		   (:addl ,movitz:+movitz-fixnum-factor+ :eax)
+		   (:jmp 'return)
+		  :any-t
 		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :eax)
 		  return)))
@@ -274,13 +289,18 @@
 		   (:testb 7 :cl)
 		   (:jnz '(:sub-program (not-a-vector)
 			   (:compile-form (:result-mode :ignore)
-			    (error "Not a vector: ~S" vector))))
+			    (error "Not a vector: ~S." vector))))
 		   (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 		   (:andl #xffff :ecx)
 		   (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 		   (:jnz '(:sub-program (not-an-index)
 			   (:compile-form (:result-mode :ignore)
-			    (error "Not a vector index: ~S" index))))
+			    (error "Not a vector index: ~S." index))))
+		   (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+			  :edx)
+		   (:jnc '(:sub-program (illegal-index)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Index ~S out of range." index))))
 		   ;; t?
 		   (:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx)
 		   (:jne 'not-any-t-vector)
@@ -317,6 +337,7 @@
 		   (:jmp 'return)
 
 		  not-u8-vector
+		   ;; u32?
 		   (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
 		   (:jne 'not-u32-vector)
 		   (:call-global-constant unbox-u32)
@@ -325,6 +346,26 @@
 		   (:jmp 'return)
 
 		  not-u32-vector
+		   ;; bit?
+		   (:cmpl ,(movitz:basic-vector-type-tag :bit) :ecx)
+		   (:jne 'not-u8-vector)
+		   (:testl ,(logxor #xffffffff (* #x1 movitz:+movitz-fixnum-factor+))
+			   :eax)
+		   (:jne '(:sub-program (not-a-bit)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Not a bit: ~S" value))))
+		   (:movl :edx :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   
+		   (:testl :eax :eax)
+		   (:jnz 'set-one-bit)
+		   (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+		  set-one-bit
+		   (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+		   
+		  not-bit-vector
 		   (:compile-form (:result-mode :ignore)
 				  (error "Not a vector: ~S" vector))
 		  return)
@@ -554,11 +595,11 @@
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%u8 (dimensions fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+(defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words (truncate (+ length 3) 4))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
-      dimensions)
+      length)
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
 		  0 :unsigned-byte32)
       #.(movitz:basic-vector-type-tag :u8))
@@ -566,16 +607,38 @@
      (fill-pointer
       (setf (fill-pointer array) fill-pointer))
      ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimensions)))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       (check-type initial-element (unsigned-byte 8))
-      (dotimes (i dimensions)
+      (dotimes (i length)
 	(setf (u8ref%unsafe array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
+(defun make-basic-vector%bit (length fill-pointer initial-element initial-contents)
+  (let ((array (malloc-data-words (truncate (+ length 31) 32))))
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+		  0 :lisp)
+      length)
+    (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:basic-vector-type-tag :bit))
+    (cond
+     (fill-pointer
+      (setf (fill-pointer array) fill-pointer))
+     ((array-has-fill-pointer-p array)
+      (setf (fill-pointer array) length)))
+    (cond
+     (initial-element
+      (check-type initial-element (unsigned-byte 8))
+      (dotimes (i length)
+	(setf (aref array i) initial-element)))
+     (initial-contents
+      (replace array initial-contents)))
+    array))
+
 (defun make-basic-vector%code (dimensions fill-pointer initial-element initial-contents)
   (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
@@ -631,6 +694,8 @@
       ;; These should be replaced by subtypep sometime.
       ((eq element-type 'character)
        (make-basic-vector%character dimensions fill-pointer initial-element initial-contents))
+      ((member element-type '(bit (unsigned-byte 1)) :test #'equal)
+       (make-basic-vector%bit dimensions fill-pointer initial-element initial-contents))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
        (make-basic-vector%u8 dimensions fill-pointer initial-element initial-contents))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)




From ffjeld at common-lisp.net  Thu Jul  8 15:28:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 08:28:57 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BiapV-00074V-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Implemented bit-vectors.

Date: Thu Jul  8 08:28:57 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.25 movitz/losp/muerte/primitive-functions.lisp:1.26
--- movitz/losp/muerte/primitive-functions.lisp:1.25	Thu Jul  8 04:30:26 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Jul  8 08:28:57 2004
@@ -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.25 2004/07/08 11:30:26 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.26 2004/07/08 15:28:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -658,6 +658,8 @@
      (movitz-accessor object movitz-funobj-standard-gf standard-gf-class))
     (string
      (find-class 'string))
+    (bit-vector
+     (find-class 'bit-vector))
     (vector
      (find-class 'vector))
     (function




From ffjeld at common-lisp.net  Thu Jul  8 18:49:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:49:26 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BidxW-0004gl-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Changed default newspace size to 1MB.

Date: Thu Jul  8 11:49:26 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.19 movitz/losp/los0-gc.lisp:1.20
--- movitz/losp/los0-gc.lisp:1.19	Wed Jul  7 16:39:50 2004
+++ movitz/losp/los0-gc.lisp	Thu Jul  8 11:49:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.19 2004/07/07 23:39:50 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.20 2004/07/08 18:49:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -247,7 +247,7 @@
 	    (:leal (:edx :ecx 8) :eax))))
     (do-it)))
 
-(defun install-los0-consing (&optional (space-kilobytes 2048))
+(defun install-los0-consing (&optional (space-kilobytes 1024))
   (let ((size (* space-kilobytes #x100)))
     (setf (%run-time-context-slot 'nursery-space)
       (allocate-duo-space size))




From ffjeld at common-lisp.net  Thu Jul  8 18:53:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:24 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bie1M-0004GK-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:24 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.41 movitz/image.lisp:1.42
--- movitz/image.lisp:1.41	Wed Jul  7 10:37:01 2004
+++ movitz/image.lisp	Thu Jul  8 11:53:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.41 2004/07/07 17:37:01 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.42 2004/07/08 18:53:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -613,7 +613,7 @@
   '(muerte.cl:null muerte.cl:cons muerte.cl:fixnum muerte.cl:symbol
     muerte.cl:character muerte.cl:function muerte.cl:condition
     muerte.cl:integer muerte.cl:ratio
-    muerte.cl:vector muerte.cl:string muerte.cl:array
+    muerte.cl:vector muerte.cl:string muerte.cl:bit-vector muerte.cl:array
     muerte.cl:class muerte.cl:standard-class
     muerte.cl:standard-generic-function
     muerte:run-time-context




From ffjeld at common-lisp.net  Thu Jul  8 18:53:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:29 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1Bie1R-0004cS-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:29 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.28 movitz/packages.lisp:1.29
--- movitz/packages.lisp:1.28	Thu Jul  8 04:28:34 2004
+++ movitz/packages.lisp	Thu Jul  8 11:53:29 2004
@@ -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.28 2004/07/08 11:28:34 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.29 2004/07/08 18:53:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1329,7 +1329,6 @@
 	   #:movitz-heap-object
 	   
 	   #:movitz-basic-vector
-	   #:movitz-vector
 	   #:movitz-vector-num-elements
 	   #:movitz-vector-element-type
 	   #:movitz-vector-symbolic-data




From ffjeld at common-lisp.net  Thu Jul  8 18:53:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:34 -0700
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1Bie1W-00050i-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:34 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.8 movitz/procfs-image.lisp:1.9
--- movitz/procfs-image.lisp:1.8	Tue Jun 29 16:15:47 2004
+++ movitz/procfs-image.lisp	Thu Jul  8 11:53:33 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.8 2004/06/29 23:15:47 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.9 2004/07/08 18:53:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -118,7 +118,7 @@
 	  (movitz-vector-symbolic-data expr)))
     (movitz-fixnum
      (movitz-fixnum-value expr))
-    ((or movitz-vector movitz-basic-vector)
+    (movitz-basic-vector
      (map 'vector #'movitz-print (movitz-vector-symbolic-data expr)))
     (movitz-cons
      (cons (movitz-print (movitz-car expr))




From ffjeld at common-lisp.net  Thu Jul  8 18:53:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:38 -0700
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <E1Bie1a-0005U3-00@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:38 2004
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.7 movitz/stream-image.lisp:1.8
--- movitz/stream-image.lisp:1.7	Tue Jun 29 16:15:52 2004
+++ movitz/stream-image.lisp	Thu Jul  8 11:53:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Aug 27 14:46:50 2001
 ;;;;                
-;;;; $Id: stream-image.lisp,v 1.7 2004/06/29 23:15:52 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.8 2004/07/08 18:53:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -89,8 +89,6 @@
 			(read-binary 'movitz-funobj (image-stream image)))
 		       (:basic-vector
 			(read-binary 'movitz-basic-vector (image-stream image)))
-		       (:vector
-			(read-binary 'movitz-vector (image-stream image)))
 		       (:defstruct
 			   (read-binary 'movitz-struct (image-stream image)))
 		       (:std-instance




From ffjeld at common-lisp.net  Thu Jul  8 18:53:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:42 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1Bie1e-00060G-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:42 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.32 movitz/losp/muerte/arrays.lisp:1.33
--- movitz/losp/muerte/arrays.lisp:1.32	Thu Jul  8 08:28:52 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Jul  8 11:53:42 2004
@@ -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.32 2004/07/08 15:28:52 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.33 2004/07/08 18:53:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,7 +22,7 @@
 (in-package muerte)
 
 (defun vector-element-type (object)
-  (memref object #.(bt:slot-offset 'movitz::movitz-vector 'movitz::element-type) 0
+  (memref object #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0
 	  :unsigned-byte8))
 
 (defmacro vector-double-dispatch ((s1 s2) &rest clauses)
@@ -44,12 +44,12 @@
 
 (define-compiler-macro vector-element-type (object)
   `(memref ,object 0
-	   #.(bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
+	   ,(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type)
 	   :unsigned-byte8))
 
 (defun (setf vector-element-type) (numeric-element-type vector)
   (check-type vector vector)
-  (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::element-type) 0
+  (setf (memref vector #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0
 		:unsigned-byte8)
     numeric-element-type))
 
@@ -75,7 +75,7 @@
      (movitz-accessor array movitz-basic-vector num-elements))))
 
 (defun shrink-vector (vector new-size)
-  (set-movitz-accessor-u16 vector movitz-vector num-elements new-size)
+  (setf-movitz-accessor (vector movitz-basic-vector num-elements) new-size)
   vector)
 
 (define-compiler-macro %basic-vector-has-fill-pointer-p (vector)
@@ -205,19 +205,19 @@
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
 		   (:declare-label-set basic-vector-dispatcher
-				       ,(print (loop with x = (make-list 8 :initial-element 'unknown)
+				       ,(loop with x = (make-list 8 :initial-element 'unknown)
 					    for et in '(:any-t :character :u8 :u32 :code :bit)
 					    do (setf (elt x (bt:enum-value
 							     'movitz::movitz-vector-element-type
 							     et))
 						 et)
-					    finally (return x))))
+					    finally (return x)))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-		   (:cmpb ,(movitz:tag :basic-vector) :cl)
-		   (:jne '(:sub-program (not-vector)
-			   (:compile-form (:result-mode :ignore)
-			    (error "Not an array: ~S." array))))
+;;;		   (:cmpb ,(movitz:tag :basic-vector) :cl)
+;;;		   (:jne '(:sub-program (not-vector)
+;;;			   (:compile-form (:result-mode :ignore)
+;;;			    (error "Not an array: ~S." array))))
 		   (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 		   (:jnz '(:sub-program (illegal-index)
 			   (:compile-form (:result-mode :ignore)
@@ -387,7 +387,7 @@
 (defun svref%unsafe (simple-vector index)
   (with-inline-assembly (:returns :eax)
     (:compile-two-forms (:eax :ebx) simple-vector index)
-    (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :eax)))
+    (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :eax)))
 
 (defun (setf svref%unsafe) (value simple-vector index)
   (setf (svref%unsafe simple-vector index) value))
@@ -745,7 +745,7 @@
 
 (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env)
   (let ((actual-index (and (movitz:movitz-constantp index env)
-			   (movitz::eval-form index env))))
+			   (movitz:movitz-eval index env))))
     (if (not (typep actual-index '(integer 0 *)))
 	`(bvref-u16-fallback ,vector ,offset ,index)
       (let ((var (gensym)))
@@ -754,11 +754,14 @@
 	       (bvref-u16-fallback ,var ,offset ,index)
 	     (with-inline-assembly (:returns :untagged-fixnum-ecx)
 	       (:compile-two-forms (:eax :ecx) ,var ,offset)
-	       (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-	       (:andl #xfffe :ecx)
-	       (:cmpw :cx (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)))
-	       (:jbe '(:sub-program () (:int 69)))
-	       (:movw (:eax :ecx ,(+ actual-index (bt:slot-offset 'movitz::movitz-vector 'movitz::data))) :cx)
+	       (:cmpl (:eax ,(bt:slot-offset 'movitz::movitz-basic-vector
+					     'movitz::num-elements))
+		      :ecx)
+	       (:jnc '(:sub-program () (:int 69)))
+	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
+	       (:movw (:eax :ecx ,(+ actual-index (bt:slot-offset 'movitz::movitz-basic-vector
+								  'movitz::data)))
+		      :cx)
 	       (:xchgb :cl :ch))))))))
 
 (defun bvref-u16-fallback (vector offset index)




From ffjeld at common-lisp.net  Thu Jul  8 18:53:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:47 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Bie1j-0006TZ-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:47 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.14 movitz/losp/muerte/inspect.lisp:1.15
--- movitz/losp/muerte/inspect.lisp:1.14	Thu Jul  8 08:23:15 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul  8 11:53:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.14 2004/07/08 15:23:15 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.15 2004/07/08 18:53:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -249,19 +249,19 @@
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 7) 8)))))
       (vector-u16
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 3) 4)))))
       ((or vector-u32 simple-vector)
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 1) 2)))))
       (structure-object
        (<= object-location




From ffjeld at common-lisp.net  Thu Jul  8 18:53:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1Bie1o-0006lu-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:52 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.11 movitz/losp/muerte/los-closette.lisp:1.12
--- movitz/losp/muerte/los-closette.lisp:1.11	Mon May 24 07:59:08 2004
+++ movitz/losp/muerte/los-closette.lisp	Thu Jul  8 11:53:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.11 2004/05/24 14:59:08 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.12 2004/07/08 18:53:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -871,7 +871,7 @@
        (:compile-form (:result-mode :eax) instance)
        (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::slots))
 	      :eax)
-       (:movl (:eax ,(+ (bt:slot-offset 'movitz::movitz-vector 'movitz::data)
+       (:movl (:eax ,(+ (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::data)
 			(* location 4)))
 	      :eax)
        (:cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset 'unbound-value)))




From ffjeld at common-lisp.net  Thu Jul  8 18:53:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:53:57 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1Bie1t-0007CT-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:53:57 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.6 movitz/losp/muerte/run-time-context.lisp:1.7
--- movitz/losp/muerte/run-time-context.lisp:1.6	Mon Apr 19 08:05:01 2004
+++ movitz/losp/muerte/run-time-context.lisp	Thu Jul  8 11:53:57 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.6 2004/04/19 15:05:01 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.7 2004/07/08 18:53:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -78,7 +78,7 @@
 	(movitz:code-vector-word
 	 `(with-inline-assembly (:returns :eax)
 	    (:compile-form (:result-mode :eax) ,value)
-	    (:leal (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :ecx)
+	    (:leal (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx)
 	    (:locally (:movl :ecx (:edi (:edi-offset ,slot-name))))))))))
 
 (defun (setf %run-time-context-slot) (value slot-name &optional (context (current-run-time-context)))




From ffjeld at common-lisp.net  Thu Jul  8 18:54:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:54:01 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1Bie1x-0008TR-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:54:01 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.23 movitz/losp/muerte/typep.lisp:1.24
--- movitz/losp/muerte/typep.lisp:1.23	Thu Jul  8 08:28:12 2004
+++ movitz/losp/muerte/typep.lisp	Thu Jul  8 11:54:01 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.23 2004/07/08 15:28:12 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.24 2004/07/08 18:54:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -76,29 +76,26 @@
 		(:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
 		(:testb 7 :cl)
 		(:branch-when :boolean-zf=0)
-		(:cmpb ,(movitz:tag tag-name)
-		       (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
 		(:branch-when :boolean-zf=0))
 	      (do-case (:boolean-branch-on-true :same :labels (other-typep-failed))
 		(:compile-form (:result-mode :eax) ,object)
 		(:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
 		(:testb 7 :cl)
 		(:jnz 'other-typep-failed)
-		(:cmpb ,(movitz:tag tag-name)
-		       (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
 		(:branch-when :boolean-zf=1)
 		other-typep-failed)
 	      (do-case (t :boolean-zf=1 :labels (other-typep-failed))
 		(:compile-form (:result-mode :eax) ,object)
-		(:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
+		(:leal (:eax ,movitz:+other-type-offset+) :ecx)
 		(:testb 7 :cl)
 		(:jnz 'other-typep-failed)
-		(:cmpb ,(movitz:tag tag-name)
-		       (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
 	       other-typep-failed)))
 	 (make-basic-vector-typep (element-type)
-	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-vector 'movitz::element-type)
-			   (bt:slot-offset 'movitz::movitz-vector 'movitz::type))))
+	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type)
+			   (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::type))))
 	   (let ((type-code (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
 				 (byte 8 8)
 				 (movitz:tag :basic-vector))))
@@ -108,16 +105,14 @@
 		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
 		  (:testb 7 :cl)
 		  (:branch-when :boolean-zf=0)
-		  (:cmpw ,type-code
-			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		  (:cmpw ,type-code (:eax ,movitz:+other-type-offset+))
 		  (:branch-when :boolean-zf=0))
 		(do-case (:boolean-branch-on-true :same :labels (vector-typep-failed))
 		  (:compile-form (:result-mode :eax) ,object)
 		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
 		  (:testb 7 :cl)
 		  (:jnz 'vector-typep-failed)
-		  (:cmpw ,type-code
-			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		  (:cmpw ,type-code (:eax ,movitz:+other-type-offset+))
 		  (:branch-when :boolean-zf=1)
 		 vector-typep-failed)
 		(do-case (t :boolean-zf=1 :labels (vector-typep-failed))
@@ -125,8 +120,7 @@
 		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
 		  (:testb 7 :cl)
 		  (:jnz 'vector-typep-failed)
-		  (:cmpw ,type-code
-			 (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type)))
+		  (:cmpw ,type-code (:eax ,movitz:+other-type-offset+))
 		 vector-typep-failed))))
 	 (make-function-typep (funobj-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-funobj 'movitz::funobj-type)




From ffjeld at common-lisp.net  Thu Jul  8 18:54:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:54:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp 
Message-ID: <E1Bie21-0000Zm-00@common-lisp.net>

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

Modified Files:
	variables.lisp 
Log Message:
Removed references to the old movitz-vector class.

Date: Thu Jul  8 11:54:05 2004
Author: ffjeld

Index: movitz/losp/muerte/variables.lisp
diff -u movitz/losp/muerte/variables.lisp:1.5 movitz/losp/muerte/variables.lisp:1.6
--- movitz/losp/muerte/variables.lisp:1.5	Tue Apr 13 07:21:19 2004
+++ movitz/losp/muerte/variables.lisp	Thu Jul  8 11:54:05 2004
@@ -1,7 +1,7 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
 ;;;;    Copyright (C) 2003-2004, 
-;;;;    Department of Computer Science, University of Tromsoe, Norway.
+;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
 ;;;; 
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov  5 21:53:34 2003
 ;;;;                
-;;;; $Id: variables.lisp,v 1.5 2004/04/13 14:21:19 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.6 2004/07/08 18:54:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 




From ffjeld at common-lisp.net  Thu Jul  8 18:59:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:59:51 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bie7b-0003kq-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Minor edits.

Date: Thu Jul  8 11:59:51 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.20 movitz/losp/los0-gc.lisp:1.21
--- movitz/losp/los0-gc.lisp:1.20	Thu Jul  8 11:49:26 2004
+++ movitz/losp/los0-gc.lisp	Thu Jul  8 11:59:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.20 2004/07/08 18:49:26 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.21 2004/07/08 18:59:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -35,10 +35,6 @@
 (defmacro space-fresh-pointer (space)
   `(memref ,space -6 2 :lisp))
 
-;;;(defmacro space-last-cons (space)
-;;;  "The location of the last cons-cell that will with in this space."
-;;;  `(memref ,space -6 3 :lisp))
-
 (defmacro space-other (space)
   `(memref ,space -6 3 :lisp))
 
@@ -49,12 +45,8 @@
     space))
 
 (defun initialize-space (space)
-  (setf (space-fresh-pointer space) 2
-;;;	(space-last-cons space) (+ (object-location space)
-;;;				   (array-dimension space 0)))
-	)
+  (setf (space-fresh-pointer space) 2)
   space)
-				   
 
 (defun allocate-duo-space (size)
   (let* ((space1 (allocate-space size))




From ffjeld at common-lisp.net  Thu Jul  8 18:59:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 11:59:56 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1Bie7g-00049Z-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Minor edits.

Date: Thu Jul  8 11:59:56 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.14 movitz/losp/los0.lisp:1.15
--- movitz/losp/los0.lisp:1.14	Mon May 24 07:58:39 2004
+++ movitz/losp/los0.lisp	Thu Jul  8 11:59:55 2004
@@ -1,15 +1,15 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001,2000, 2002-2004,
+;;;;    Copyright (C) 2000-2004,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      los0.lisp
-;;;; Description:   Top-level initialization file.
+;;;; Description:   Top-level initialization and testing.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.14 2004/05/24 14:58:39 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.15 2004/07/08 18:59:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -80,6 +80,13 @@
 ;;;  (declare (dynamic-extent args))
 ;;;  (apply (constantly 'test-value) args))
 
+(defun test-break ()
+  (with-inline-assembly (:returns :multiple-values)
+    (:movl 10 :ecx)
+    (:movl :esi :eax)			; This function should return itself!
+    (:clc)
+    (:break)))
+
 (defun test-upload (x)
   ;; (warn "Test-upload blab la bla!!")
   (setf x (cdr x))
@@ -266,14 +273,68 @@
 (defun test-bignum ()
   123456789123456)
 
-(defun ff32 ()
-  #xffffffff)
+(defun fe32 ()
+  #xfffffffe)
+
+(defun fe64 ()
+  #xfffffffffffffffe)
+
+(defun fe96 ()
+  #xfffffffffffffffffffffffe)
 
 (defun one32 ()
   #x100000000)
 
-(defun test-nbignum ()
-  -123456789123456)
+(defun z (op x y)
+  (let ((foo (cons 1 2))
+	(result (funcall op x y))
+	(bar (cons 3 4)))
+    (if (not (typep result 'pointer))
+	(warn "foo: ~Z result: ~Z, bar: ~Z, diff foo-bar: ~D."
+	      foo result bar
+	      (- (object-location bar) (object-location foo)))
+      (warn "foo: ~Z result: ~Z, bar: ~Z, diff: ~D, ~D."
+	    foo result bar
+	    (- (object-location result) (object-location foo))
+	    (- (object-location bar) (object-location result))))
+    (values foo result bar)))
+
+(defun foo (number &rest more-numbers)
+  (declare (dynamic-extent more-numbers))
+  (do ((p more-numbers (cdr p)))
+      ((not (cdr p)) number)
+    (unless (< (car p) (cadr p))
+      (return nil))))
+
+(defun modx (x)
+  (lambda ()
+    (print x)))
+
+(defun mod30 (x)
+  (ldb (Byte 30 0) x))
+
+(defun mod32-4 (x)
+  (ldb (byte 28 4) x))
+
+(defun mod24-4 (x)
+  (ldb (Byte 24 4) x))
+
+(defun zz (op x y)
+  (let ((foo (vector 1 2))
+	(result (funcall op x y))
+	(bar (vector 3 4)))
+    (if (not (typep result 'pointer))
+	(warn "foo: ~Z result: ~Z, bar: ~Z, diff foo-bar: ~D."
+	      foo result bar
+	      (- (object-location bar) (object-location foo)))
+      (warn "foo: ~Z result: ~Z, bar: ~Z, diff: ~D, ~D."
+	    foo result bar
+	    (- (object-location result) (object-location foo))
+	    (- (object-location bar) (object-location result))))
+    (values foo result bar)))
+
+(defun testb ()
+  #(1 2 3 4))
 
 (defun gt5 (x)
   (<= x 5))
@@ -632,9 +693,6 @@
 (defun test-nano-sleep (x)
   (time (nano-sleep x)))
 
-(defun test ()
-  (time 123))
-
 (defun mvtest ()
   (multiple-value-call #'list (round 5 2))
   (list (memref-int #x1000000 0 0 :unsigned-byte8)
@@ -730,7 +788,8 @@
 		(format t " ~~ ~,3F" x)))
 	     (pointer
 	      (format t "~&~Z = ~W" x x))
-	     (t (write x :radix nil :base (case *print-base* (10 16) (t 10)))))
+	     (t (fresh-line)
+		(write x :radix nil :base (case *print-base* (10 16) (t 10)))))
 	   x))
     (if x-list
 	(do-print (eval x-list))
@@ -782,7 +841,8 @@
 	  (write (cdr condition))))
        (t (format t "~&Error: ~A" condition)))
       (if *debugger-printing-restarts*
-	  (format t "~&[restarts suppressed]")
+	  (progn (format t "~&[restarts suppressed]")
+		 (halt-cpu))
 	(let ((*debugger-printing-restarts* t))
 	  (map-active-restarts (lambda (restart index)
 				 (format t "~&~2D: ~A~%" index restart))
@@ -881,10 +941,11 @@
   (idt-init)
   (install-los0-consing)
   
+  (setf *debugger-function* #'los0-debugger)
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 	(*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
-	(*debugger-function* #'los0-debugger)
+	#+ignore (*debugger-function* #'los0-debugger)
 	(*package* nil))
     (with-simple-restart (abort "Skip Los0 boot-up initialization.")
       (setf *cpu-features*




From ffjeld at common-lisp.net  Thu Jul  8 21:48:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 14:48:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BiglG-0000VV-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Added %bignum-canonicalize.

Date: Thu Jul  8 14:48:58 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.15 movitz/losp/muerte/inspect.lisp:1.16
--- movitz/losp/muerte/inspect.lisp:1.15	Thu Jul  8 11:53:47 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul  8 14:48:58 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.15 2004/07/08 18:53:47 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.16 2004/07/08 21:48:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -245,7 +245,7 @@
 	   (+ -1 object-location
 	      #.(movitz::movitz-type-word-size :movitz-funobj)
 	      (funobj-num-constants object))))
-      ((or string code-vector (simple-array (unsigned-byte 8)))
+      ((or string code-vector (simple-array (unsigned-byte 8) 1))
        (<= object-location
 	   location
 	   (+ -1 object-location
@@ -272,6 +272,37 @@
 
 (defun %bignum-bigits (x)
   (%bignum-bigits x))
+
+(defun %bignum-canonicalize (x)
+  "Assuming x is a bignum, return the canonical integer value. That is,
+either return a fixnum, or destructively modify the bignum's length so
+that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:load-lexical (:lexical-binding x) :eax)
+	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+	    (:shrl 16 :ecx)
+	   shrink-loop
+	    (:cmpl 1 :ecx)
+	    (:je 'shrink-no-more)
+	    (:cmpl 0 (:eax (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+	    (:jnz 'shrink-done)
+	    (:subl 1 :ecx)
+	    (:jmp 'shrink-loop)
+	   shrink-no-more
+	    (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+)
+		   (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:jc '(:sub-program (fixnum-result)
+		   (:movl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		    :ecx)
+		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+		   (:jmp 'done)))
+	   shrink-done
+	    (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
+	   done
+	    )))
+    (do-it)))
 
 (defun copy-bignum (old)
   (check-type old bignum)




From ffjeld at common-lisp.net  Thu Jul  8 21:50:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 14:50:03 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BigmJ-0002zJ-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Slightly more correct dealing with simple-array type.

Date: Thu Jul  8 14:50:03 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.24 movitz/losp/muerte/typep.lisp:1.25
--- movitz/losp/muerte/typep.lisp:1.24	Thu Jul  8 11:54:01 2004
+++ movitz/losp/muerte/typep.lisp	Thu Jul  8 14:50:03 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.24 2004/07/08 18:54:01 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.25 2004/07/08 21:50:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -260,15 +260,20 @@
 		    `(typep ,object ',(apply deriver-function (cdr type)))
 		  (case (car type)
 		    ((simple-array)
-		     (let ((et (cadr type)))
-		       (cond
-			((movitz:movitz-subtypep et '(unsigned-byte 8))
-			 (make-basic-vector-typep :u8))
-			((movitz:movitz-subtypep et '(unsigned-byte 32))
-			 (make-basic-vector-typep :u32))
-			((movitz:movitz-subtypep et 'character)
-			 (make-basic-vector-typep :character))
-			(t (make-basic-vector-typep :any-t)))))
+		     (let ((et (second type))
+			   (dim (if (listp (third type))
+				    (length (third type))
+				  (or (third type) '*))))
+		       (if (not (eql dim 1))
+			   form
+			 (cond
+			  ((movitz:movitz-subtypep et '(unsigned-byte 8))
+			   (make-basic-vector-typep :u8))
+			  ((movitz:movitz-subtypep et '(unsigned-byte 32))
+			   (make-basic-vector-typep :u32))
+			  ((movitz:movitz-subtypep et 'character)
+			   (make-basic-vector-typep :character))
+			  (t (make-basic-vector-typep :any-t))))))
 		    ((integer)
 		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
 			 (cdr type)




From ffjeld at common-lisp.net  Thu Jul  8 21:51:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 14:51:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BignM-0004Bc-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Corrected logxor for bignums.

Date: Thu Jul  8 14:51:08 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.39 movitz/losp/muerte/integers.lisp:1.40
--- movitz/losp/muerte/integers.lisp:1.39	Thu Jul  8 04:30:20 2004
+++ movitz/losp/muerte/integers.lisp	Thu Jul  8 14:51:08 2004
@@ -1,15 +1,15 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 2000-2004,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      integers.lisp
-;;;; Description:   
+;;;; Description:   Arithmetics.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.39 2004/07/08 11:30:20 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.40 2004/07/08 21:51:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1552,12 +1552,14 @@
 	 (with-inline-assembly (:returns :eax)
 	   (:compile-two-forms (:eax :ebx) x y)
 	   (:xorl :ebx :eax)))
+	(((eql 0) t) y)
+	((t (eql 0)) x)
 	((positive-fixnum positive-bignum)
 	 (macrolet
 	     ((do-it ()
 		`(let ((r (copy-bignum y)))
 		   (with-inline-assembly (:returns :eax)
-		     (:compile-two-forms (:eax :ecx) y x)
+		     (:compile-two-forms (:eax :ecx) r x)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		     (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx)))))
 	   (do-it)))
@@ -1572,34 +1574,29 @@
 	   (do-it)))
 	((positive-bignum positive-bignum)
 	 (if (< (%bignum-bigits x) (%bignum-bigits y))
-	     (logior y x)
+	     (logxor y x)
 	   (let ((r (copy-bignum x)))
 	     (macrolet
 		 ((do-it ()
-		    `(with-inline-assembly (:returns :eax)
-		       (:compile-two-forms (:eax :ebx) r y)
-		       (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-				:ecx)
-		       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
-			       ,(* -1 movitz:+movitz-fixnum-factor+))
-			      :edx)	; EDX is loop counter
-		      or-loop
-		       (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-			      :ecx)
-		       (:orl :ecx
-			     (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		       (:subl 4 :edx)
-		       (:jnc 'or-loop))))
-	       (do-it))))))
-      (number-double-dispatch (x y)
-	(((eql 0) t) y)
-	((t (eql 0)) x)
-	((fixnum fixnum)
-	 (with-inline-assembly (:returns :eax)
-	   (:compile-form (:result-mode :eax) x)
-	   (:compile-form (:result-mode :ecx) y)
-	   ;; (:orl #.movitz:+movitz-fixnum-zmask+ :ecx)
-	   (:xorl :ecx :eax)))))
+		    `(%bignum-canonicalize
+		      (with-inline-assembly (:returns :eax)
+			(:compile-two-forms (:eax :ebx) r y)
+			(:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+				 :ecx)
+			(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
+				,(* -1 movitz:+movitz-fixnum-factor+))
+			       :edx)	; EDX is loop counter
+		       xor-loop
+			(:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+			       :ecx)
+			(:xorl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			(:subl 4 :edx)
+			(:jnc 'xor-loop)
+		       
+			(:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+				 :ecx)))))
+	       (do-it)))))))
    (t (&rest integers)
       (declare (dynamic-extent integers))
       (if (null integers)




From ffjeld at common-lisp.net  Thu Jul  8 21:51:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 14:51:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1Bigo0-0004na-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Removed dead code.

Date: Thu Jul  8 14:51:48 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.33 movitz/losp/muerte/arrays.lisp:1.34
--- movitz/losp/muerte/arrays.lisp:1.33	Thu Jul  8 11:53:42 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Jul  8 14:51:48 2004
@@ -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.33 2004/07/08 18:53:42 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.34 2004/07/08 21:51:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -214,10 +214,6 @@
 					    finally (return x)))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-;;;		   (:cmpb ,(movitz:tag :basic-vector) :cl)
-;;;		   (:jne '(:sub-program (not-vector)
-;;;			   (:compile-form (:result-mode :ignore)
-;;;			    (error "Not an array: ~S." array))))
 		   (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 		   (:jnz '(:sub-program (illegal-index)
 			   (:compile-form (:result-mode :ignore)




From ffjeld at common-lisp.net  Thu Jul  8 21:52:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 08 Jul 2004 14:52:29 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1Bigof-0006Q3-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Added top-level command :z that prints word values.

Date: Thu Jul  8 14:52:29 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.15 movitz/losp/los0.lisp:1.16
--- movitz/losp/los0.lisp:1.15	Thu Jul  8 11:59:55 2004
+++ movitz/losp/los0.lisp	Thu Jul  8 14:52:29 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.15 2004/07/08 18:59:55 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.16 2004/07/08 21:52:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -790,6 +790,15 @@
 	      (format t "~&~Z = ~W" x x))
 	     (t (fresh-line)
 		(write x :radix nil :base (case *print-base* (10 16) (t 10)))))
+	   x))
+    (if x-list
+	(do-print (eval x-list))
+      (dolist (x cl:/ (values-list cl:/))
+	(do-print x)))))
+
+(define-toplevel-command :z (&optional x-list)
+  (flet ((do-print (x)
+	   (format t "~&~Z => ~S" x x)
 	   x))
     (if x-list
 	(do-print (eval x-list))




From ffjeld at common-lisp.net  Fri Jul  9 11:16:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 04:16:26 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BitMg-0003nx-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Removed dead code.

Date: Fri Jul  9 04:16:24 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.42 movitz/image.lisp:1.43
--- movitz/image.lisp:1.42	Thu Jul  8 11:53:24 2004
+++ movitz/image.lisp	Fri Jul  9 04:16:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.42 2004/07/08 18:53:24 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.43 2004/07/09 11:16:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -330,38 +330,6 @@
 			(movitz-read-and-intern (funcall 'muerte::movitz-find-class x)
 						'word))
     :map-binary-read-delayed 'movitz-word)
-;;;   (the-class-fixnum
-;;;    :binary-type word
-;;;    :initform 'fixnum
-;;;    :map-binary-write (lambda (x type)
-;;;			(declare (ignore type))
-;;;			(movitz-read-and-intern (funcall 'muerte::movitz-find-class x)
-;;;					     'word))
-;;;    :map-binary-read-delayed 'movitz-word)
-;;;   (the-class-cons
-;;;    :binary-type word
-;;;    :initform 'cons
-;;;    :map-binary-write (lambda (x type)
-;;;			(declare (ignore type))
-;;;			(movitz-read-and-intern (funcall 'muerte::movitz-find-class x)
-;;;					     'word))
-;;;    :map-binary-read-delayed 'movitz-word)
-;;;   (the-class-null
-;;;    :binary-type word
-;;;    :initform 'null
-;;;    :map-binary-write (lambda (x type)
-;;;			(declare (ignore type))
-;;;			(movitz-read-and-intern (funcall 'muerte::movitz-find-class x)
-;;;					     'word))
-;;;    :map-binary-read-delayed 'movitz-word)
-;;;   (the-class-symbol
-;;;    :binary-type word
-;;;    :initform 'symbol
-;;;    :map-binary-write (lambda (x type)
-;;;			(declare (ignore type))
-;;;			(movitz-read-and-intern (funcall 'muerte::movitz-find-class x)
-;;;					     'word))
-;;;    :map-binary-read-delayed 'movitz-word)
    (interrupt-handlers
     :binary-type word
     :map-binary-write 'movitz-intern




From ffjeld at common-lisp.net  Fri Jul  9 12:48:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 05:48:05 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <E1BiunN-0003Sp-00@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Fixed bug in numscope-add-range.

Date: Fri Jul  9 05:48:02 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.16 movitz/compiler-types.lisp:1.17
--- movitz/compiler-types.lisp:1.16	Thu Jul  8 04:27:19 2004
+++ movitz/compiler-types.lisp	Fri Jul  9 05:48:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.16 2004/07/08 11:27:19 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.17 2004/07/09 12:48:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -118,15 +118,17 @@
 	      (push sub-range new-numscope)
 	    (setf new-min (and new-min (min new-min (car sub-range)))
 		  new-max nil)))
-	 ((cond
+	 ((cond				; is <new-min, new-max> overlapping sub-range?
 	   ((and (not new-min) (not new-max)) t)
 	   ((not new-min) (<= (car sub-range) (+ epsilon new-max)))
 	   ((not new-max) (<= new-min (+ epsilon (cdr sub-range))))
 	   ((<= (- new-min epsilon) (car sub-range) (+ new-max epsilon)) t)
-	   ((<= (- new-min epsilon) (cdr sub-range) (+ new-max epsilon)) t))
+	   ((<= (- new-min epsilon) (cdr sub-range) (+ new-max epsilon)) t)
+	   ((<= (car sub-range) new-min (cdr sub-range))))
 	  (setf new-min (and new-min (min new-min (car sub-range)))
 		new-max (and new-max (max new-max (cdr sub-range)))))
-	 (t (push sub-range new-numscope))))
+	 (t ;; (warn "Unaffected sub-range: ~A for ~D-~D" sub-range new-min new-max)
+	    (push sub-range new-numscope))))
       (sort (cons (cons new-min new-max) new-numscope)
 	    (lambda (x y)
 	      (and x y (< x y)))




From ffjeld at common-lisp.net  Fri Jul  9 16:10:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 09:10:26 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <E1BixxC-0005Vg-00@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Changed handling of integers back again to having both an integer code
and integer-range. Also, added encoded-integer-types-add.

Date: Fri Jul  9 09:10:26 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.17 movitz/compiler-types.lisp:1.18
--- movitz/compiler-types.lisp:1.17	Fri Jul  9 05:48:01 2004
+++ movitz/compiler-types.lisp	Fri Jul  9 09:10:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.17 2004/07/09 12:48:01 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.18 2004/07/09 16:10:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -211,11 +211,29 @@
     (and x (not (car x)) (not (cdr x)))))
     
 
+(defun numscope-combine (function range0 range1)
+  (let ((result ()))
+    (dolist (sub-range0 range0)
+      (dolist (sub-range1 range1)
+	(setf result
+	  (numscope-union result
+			  (funcall function
+				   (car sub-range0) (cdr sub-range0)
+				   (car sub-range1) (cdr sub-range1))))))
+    result))
+
+(defun numscope-plus (range0 range1)
+  "Return the numscope that covers the sum of any element of range0
+and any element of range1."
+  (numscope-combine (lambda (min0 max0 min1 max1)
+		      (make-numscope (and min0 min1 (+ min0 min1))
+				     (and max0 max1 (+ max0 max1))))
+		    range0 range1))
 
 ;;;
 
 (defparameter *tb-bitmap*
-    '(hash-table character function cons keyword symbol vector array :tail)
+    '(hash-table character function cons keyword symbol vector array integer :tail)
   "The union of these types must be t.")
 
 (defun basic-typep (x type)
@@ -253,37 +271,11 @@
 		     (case x
 		       (symbol (logior code (code 'keyword)))
 		       (array  (logior code (code 'vector)))
+		       ;; (number (logior code (code 'integer)))
 		       (t code)))))))
       (reduce #'logior (mapcar #'code types)
 	      :initial-value (code first-type)))))
 
-(defun type-values (codes &key integer-range members include complement)
-  ;; Members: A list of objects explicitly included in type.
-  ;; Include: A list of (non-encodable) type-specs included in type.
-  (check-type include list)
-  (check-type members list)
-  (check-type integer-range list)
-  (let ((new-intscope integer-range)
-	(new-members ()))
-    (dolist (member members)		; move integer members into integer-range
-      (let ((member (movitz-read member)))
-	(etypecase member
-	  (movitz-fixnum
-	   (setf new-intscope
-	     (numscope-union new-intscope	    
-			     (make-numscope (movitz-fixnum-value member)
-					    (movitz-fixnum-value member)))))
-	  (movitz-object
-	   (pushnew member new-members :test #'movitz-eql)))))
-    (let ((new-code (if (atom codes)
-			(type-code codes)
-		      (apply #'type-code codes))))
-      (values new-code
-	      new-intscope
-	      new-members
-	      include
-	      complement))))
-		  
 (defun encoded-type-decode (code integer-range members include complement)
   (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
 	(= mask (logand mask code)))
@@ -313,6 +305,38 @@
        (t (if (not complement)
 	      (cons 'or sub-specs)
 	    (list 'not (cons 'or sub-specs))))))))
+		  
+(defun type-values (codes &key integer-range members include complement)
+  ;; Members: A list of objects explicitly included in type.
+  ;; Include: A list of (non-encodable) type-specs included in type.
+  (check-type include list)
+  (check-type members list)
+  (check-type integer-range list)
+  (let ((new-intscope integer-range)
+	(new-members ()))
+    (dolist (member members)		; move integer members into integer-range
+      (let ((member (movitz-read member)))
+	(etypecase member
+	  (movitz-fixnum
+	   (setf new-intscope
+	     (numscope-union new-intscope	    
+			     (make-numscope (movitz-fixnum-value member)
+					    (movitz-fixnum-value member)))))
+	  (movitz-object
+	   (pushnew member new-members :test #'movitz-eql)))))
+    (let ((new-code (logior (if (atom codes)
+				(type-code codes)
+			      (apply #'type-code codes))
+			    (if (numscope-allp new-intscope)
+				(type-code 'integer)
+			      0))))
+      (values new-code
+	      (if (type-code-p 'integer new-code)
+		  (make-numscope nil nil)
+		new-intscope)
+	      new-members
+	      include
+	      complement))))
 
 (defun star-is-t (x)
   (if (eq x '*) t x))
@@ -330,9 +354,13 @@
 		((typep x 'movitz-nil)
 		 (type-code-p 'symbol code))
 		((basic-typep x 'fixnum)
-		 (numscope-memberp integer-range (movitz-fixnum-value x)))
+		 (or (type-code-p 'integer code)
+		     (and integer-range
+			  (numscope-memberp integer-range (movitz-fixnum-value x)))))
 		((basic-typep x 'bignum)
-		 (numscope-memberp integer-range (movitz-bignum-value x)))
+		 (or (type-code-p 'integer code)
+		     (and integer-range
+			  (numscope-memberp integer-range (movitz-bignum-value x)))))
 		(t (dolist (bt '(symbol character function cons hash-table vector)
 			     (error "Cant decide typep for ~S." x))
 		     (when (basic-typep x bt)
@@ -411,9 +439,13 @@
     (values code0 integer-range0 members0 include0 complement0))
    ((and (not complement0) (not complement1))
     (let* ((new-inumscope (numscope-union integer-range0 integer-range1))
-	   (new-code (logior code0 code1)))
+	   (new-code (logior code0 code1 (if (numscope-allp new-inumscope)
+					     (type-code 'integer)
+					   0))))
       (values new-code
-	      new-inumscope
+	      (if (type-code-p 'integer new-code)
+		  nil
+		new-inumscope)
 	      (remove-if (lambda (x)
 			   (or (encoded-typep nil t x code0 integer-range0 nil include0 nil)
 			       (encoded-typep nil t x code1 integer-range1 nil include1 nil)))
@@ -443,10 +475,8 @@
 	(bignum
 	 (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+))
 				     (integer ,(1+ +movitz-most-positive-fixnum+) *))))
-	((t nil cons symbol keyword function array vector hash-table character)
+	((t nil cons symbol keyword function array vector integer hash-table character)
 	 (type-values type-specifier))
-	((integer)
-	 (type-values () :integer-range (make-numscope)))
 	(null
 	 (type-values () :members '(nil)))
 	(list
@@ -573,10 +603,10 @@
     (values nil t))
    (t (values nil nil))))
 
-(defun encoded-integerp (code integer-range members include complement)
-  "Is the encoded-type a subset/subtype of integer?"
-  (declare (ignore integer-range))
-  (and (= 0 code) (null members) (null include) (not complement)))
+(defun encoded-numscope (code integer-range)
+  (if (type-code-p 'integer code)
+      (make-numscope nil nil)
+    integer-range))
 
 (defun encoded-subtypep (code0 integer-range0 members0 include0 complement0
 			 code1 integer-range1 members1 include1 complement1)
@@ -601,17 +631,13 @@
 	       (and (not all1) confident)))
 	;; type0 is t, and type1 isn't.
 	(result-is nil t))
-       ((and (encoded-integerp code0 integer-range0 members0 include0 complement0)
-	     (not complement1)
-	     (numscope-subsetp integer-range0 integer-range1))
-	;; type0 is an integer type which is included in type1.
-	(result-is t t))
        ((and (not complement0) (not complement1))
 	(dolist (st *tb-bitmap*)
 	  (when (type-code-p st code0)
 	    (unless (type-code-p st code1)
 	      (result-is nil t))))
-	(unless (numscope-subsetp integer-range0 integer-range1)
+	(unless (numscope-subsetp (encoded-numscope code0 integer-range0)
+				  (encoded-numscope code1 integer-range1))
 	  (result-is nil t))
 	(dolist (m members0)
 	  (ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil)
@@ -643,8 +669,26 @@
    ((and (null members) (null intscope))
     (warn "Not singleton, nulloton."))))
 
-(defun movitz-subtypep (type1 type2)
+(defun movitz-subtypep (type0 type1)
   "Compile-time subtypep."
   (multiple-value-call #'encoded-subtypep
-    (type-specifier-encode type1)
-    (type-specifier-encode type2)))
+    (type-specifier-encode type0)
+    (type-specifier-encode type1)))
+
+(defun encoded-integer-types-add (code0 integer-range0 members0 include0 complement0
+				  code1 integer-range1 members1 include1 complement1)
+  "Return the integer type that can result from adding a member of type0 to a member of type1."
+  (declare (ignore members0 members1))
+  (cond
+   ((or include0 include1)
+    ;; We can't know..
+    'integer)
+   ((or complement0 complement1)
+    (break "adding complement types..?"))
+   (t (let ((integer-range (numscope-plus (encoded-numscope code0 integer-range0)
+					  (encoded-numscope code1 integer-range1))))
+	(encoded-type-decode (if (not (numscope-allp integer-range))
+				 0
+			       (type-code 'integer))
+			     integer-range
+			     nil nil nil)))))




From ffjeld at common-lisp.net  Fri Jul  9 16:11:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 09:11:20 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bixy4-0006sW-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Implementing :add extended-code.

Date: Fri Jul  9 09:11:20 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.70 movitz/compiler.lisp:1.71
--- movitz/compiler.lisp:1.70	Wed Jul  7 10:34:09 2004
+++ movitz/compiler.lisp	Fri Jul  9 09:11:20 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.70 2004/07/07 17:34:09 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.71 2004/07/09 16:11:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -459,7 +459,7 @@
 		   (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis))
 		     (warn "Singleton: ~A" binding))
 		   #+ignore
-		   (when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
+		   (when (or t #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
 			     #+ignore (multiple-value-call #'encoded-subtypep
 					(values-list (type-analysis-encoded-type analysis))
 					(type-specifier-encode 'list)))
@@ -3024,6 +3024,9 @@
 		   (when x (return t)))))))
     (code-search code binding load store call)))
 
+(defun bindingp (x)
+  (typep x 'binding))
+
 (defun binding-target (binding)
   "Resolve a binding in terms of forwarding."
   (etypecase binding
@@ -5759,7 +5762,7 @@
      `(binding-type ,binding))))
 
 (defun binding-store-subtypep (binding type-specifier)
-  "Is type-specifier a subtype of all values ever stored to binding?
+  "Is type-specifier a supertype of all values ever stored to binding?
    (Assuming analyze-bindings has put this information into binding-store-type.)"
   (if (not (binding-store-type binding))
       nil
@@ -6083,3 +6086,59 @@
   (destructuring-bind (object result-mode &key (op :movl))
       (cdr instruction)
     (make-load-constant object result-mode funobj frame-map :op op)))
+
+;;;;; Add
+
+(define-find-write-binding-and-type :add (instruction)
+  (destructuring-bind (term0 term1 destination)
+      (cdr instruction)
+    (declare (ignore term0 term1))
+    (when (typep destination 'binding)
+      (values destination 'integer))))
+
+(define-find-read-bindings :add (term0 term1 destination)
+  (declare (ignore destination))
+  (remove-if-not #'bindingp (list term0 term1)))
+
+(define-extended-code-expander :add (instruction funobj frame-map)
+  (destructuring-bind (term0 term1 destination)
+      (cdr instruction)
+    (cond
+     ((and (bindingp term0)
+	   (bindingp term1)
+	   (member destination
+		   '(:function :multple-values :eax :ebx :ecx :edx)))
+      #+ignore
+      (when (and (binding-store-subtypep term0 'fixnum)
+		 (binding-store-subtypep term1 'fixnum)
+		 (movitz-subtypep (multiple-value-call #'encoded-integer-types-add
+				    (values-list (binding-store-type term0))
+				    (values-list (binding-store-type term1)))
+				  'fixnum))
+	(warn "add: ~S~%~A => ~A~%~S, ~S"
+	      instruction
+	      (binding-type-specifier term0)
+	      (binding-type-specifier term1)
+	      (binding-store-subtypep term0 'fixnum)
+	      (binding-store-subtypep term1 'fixnum)))
+      (let ((loc0 (new-binding-location term0 frame-map :default nil))
+	    (loc1 (new-binding-location term1 frame-map :default nil)))
+	(append (cond
+		 ((and (eq :eax loc0) (eq :ebx loc1))
+		  nil)
+		 ((and (eq :ebx loc0) (eq :eax loc1))
+		  nil)			; terms order isn't important
+		 ((eq :eax loc1)
+		  (append
+		   (make-load-lexical term0 :ebx funobj nil frame-map)))
+		 (t (append
+		     (make-load-lexical term0 :eax funobj nil frame-map)
+		     (make-load-lexical term1 :ebx funobj nil frame-map))))
+		`((:movl (:edi ,(global-constant-offset '+)) :esi))
+		(make-compiled-funcall-by-esi 2)
+		(ecase destination
+		  ((:function :multple-values :eax))
+		  ((:ebx :ecx :edx)
+		   `((:movl :eax ,destination))))
+		)))
+     (t (error "Unknown add: ~S" instruction)))))




From ffjeld at common-lisp.net  Fri Jul  9 16:12:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 09:12:10 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bixys-0002kh-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added global-function + to constant-block.

Date: Fri Jul  9 09:12:10 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.43 movitz/image.lisp:1.44
--- movitz/image.lisp:1.43	Fri Jul  9 04:16:24 2004
+++ movitz/image.lisp	Fri Jul  9 09:12:10 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.43 2004/07/09 11:16:24 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.44 2004/07/09 16:12:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -284,6 +284,12 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
+   (+
+    :initform 'muerte.cl:+
+    :binary-type word
+    :binary-tag :global-function
+    :map-binary-write 'movitz-intern
+    :map-binary-read-delayed 'movitz-word)
    (complicated-class-of
     :binary-type word
     :binary-tag :global-function
@@ -734,6 +740,13 @@
      (check-type (cdr object) movitz-funobj)
      (+ (car object) (movitz-intern-code-vector (cdr object) type)))))
 
+(defun movitz-intern-global-function (object &optional (type 'word))
+  (assert (eq type 'word))
+  (check-type object symbol)
+  (let ((x (movitz-env-named-function object)))
+    (check-type x movitz-funobj)
+    (movitz-intern x 'word)))
+
 (defun movitz-word-code-vector (word &optional (type 'code-vector-word))
   (assert (eq type 'code-vector-word))
   (movitz-word (- word +code-vector-word-offset+)))
@@ -853,7 +866,7 @@
 	  ;; pull in functions in constant-block
 	  (dolist (gcf-name (binary-record-slot-names 'movitz-constant-block :match-tags :global-function))
 	    (let* ((gcf-movitz-name (movitz-read (intern (symbol-name gcf-name)
-						  ':muerte)))
+							 ':muerte)))
 		   (gcf-funobj (movitz-symbol-function-value gcf-movitz-name)))
 	      (setf (slot-value constant-block gcf-name) 0)
 	      (cond




From ffjeld at common-lisp.net  Fri Jul  9 16:12:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 09 Jul 2004 09:12:44 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BixzQ-0003Dd-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Minor edit.

Date: Fri Jul  9 09:12:44 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.23 movitz/special-operators.lisp:1.24
--- movitz/special-operators.lisp:1.23	Sun Jun  6 08:12:40 2004
+++ movitz/special-operators.lisp	Fri Jul  9 09:12:44 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.23 2004/06/06 15:12:40 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.24 2004/07/09 16:12:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1092,7 +1092,7 @@
 	  :forward all
 	  :form (+ (eval-form term1 env)
 		   (eval-form term2 env))))
-       ((and (movitz-constantp term1 env)	; first operand zero?
+       ((and (movitz-constantp term1 env) ; first operand zero?
 	     (zerop (eval-form term1 env)))
 	(compiler-call #'compile-form-unprotected
 	  :forward all




From ffjeld at common-lisp.net  Sat Jul 10 13:29:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 10 Jul 2004 06:29:11 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BjHuh-00038b-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Re-working the compilation of addition. Now use a proper extended-code
instruction (which is like a "vop", I think).

Date: Sat Jul 10 06:29:11 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.71 movitz/compiler.lisp:1.72
--- movitz/compiler.lisp:1.71	Fri Jul  9 09:11:20 2004
+++ movitz/compiler.lisp	Sat Jul 10 06:29:11 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.71 2004/07/09 16:11:20 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.72 2004/07/10 13:29:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -389,6 +389,9 @@
 			      (member-type-encode (constant-object target-binding))))))
 			(t (pushnew target-binding (type-analysis-binding-types analysis))
 			   (setf more-binding-references-p t)))))
+		    ((and (bindingp type)
+			  (binding-eql type binding))
+		     nil)
 		    (t (setf (type-analysis-encoded-type analysis)
 			 (multiple-value-list
 			  (multiple-value-call
@@ -5425,7 +5428,6 @@
 	   (compiler-values ()
 	     :code (make-compiled-lexical-load binding returns)
 	     :final-form binding
-	     :type (binding-type-specifier binding)
 	     :returns returns
 	     :functional-p t))))))
 
@@ -6098,47 +6100,88 @@
 
 (define-find-read-bindings :add (term0 term1 destination)
   (declare (ignore destination))
-  (remove-if-not #'bindingp (list term0 term1)))
+  (list term0 term1))
 
 (define-extended-code-expander :add (instruction funobj frame-map)
   (destructuring-bind (term0 term1 destination)
       (cdr instruction)
-    (cond
-     ((and (bindingp term0)
-	   (bindingp term1)
-	   (member destination
-		   '(:function :multple-values :eax :ebx :ecx :edx)))
-      #+ignore
-      (when (and (binding-store-subtypep term0 'fixnum)
-		 (binding-store-subtypep term1 'fixnum)
-		 (movitz-subtypep (multiple-value-call #'encoded-integer-types-add
-				    (values-list (binding-store-type term0))
-				    (values-list (binding-store-type term1)))
-				  'fixnum))
-	(warn "add: ~S~%~A => ~A~%~S, ~S"
-	      instruction
-	      (binding-type-specifier term0)
-	      (binding-type-specifier term1)
-	      (binding-store-subtypep term0 'fixnum)
-	      (binding-store-subtypep term1 'fixnum)))
+    (assert (and (bindingp term0)
+		 (bindingp term1)
+		 (member (result-mode-type destination)
+			 '(:lexical-binding :function :multple-values :eax :ebx :ecx :edx))))
+    (let* ((term0 (binding-target term0))
+	   (term1 (binding-target term1))
+	   (destination (if (or (not (bindingp destination))
+				(not (symbolp (new-binding-location destination frame-map :default 0))))
+			    destination
+			  (new-binding-location destination frame-map)))
+	   (type0 (apply #'encoded-type-decode (binding-store-type term0)))
+	   (type1 (apply #'encoded-type-decode (binding-store-type term1)))
+	   (result-type (multiple-value-call #'encoded-integer-types-add
+			  (values-list (binding-store-type term0))
+			  (values-list (binding-store-type term1)))))
+      ;; (warn "add for: ~S is ~A." destination result-type)
       (let ((loc0 (new-binding-location term0 frame-map :default nil))
 	    (loc1 (new-binding-location term1 frame-map :default nil)))
-	(append (cond
-		 ((and (eq :eax loc0) (eq :ebx loc1))
-		  nil)
-		 ((and (eq :ebx loc0) (eq :eax loc1))
-		  nil)			; terms order isn't important
-		 ((eq :eax loc1)
-		  (append
-		   (make-load-lexical term0 :ebx funobj nil frame-map)))
-		 (t (append
-		     (make-load-lexical term0 :eax funobj nil frame-map)
-		     (make-load-lexical term1 :ebx funobj nil frame-map))))
-		`((:movl (:edi ,(global-constant-offset '+)) :esi))
-		(make-compiled-funcall-by-esi 2)
-		(ecase destination
-		  ((:function :multple-values :eax))
-		  ((:ebx :ecx :edx)
-		   `((:movl :eax ,destination))))
-		)))
-     (t (error "Unknown add: ~S" instruction)))))
+	(cond
+	 ((type-specifier-singleton result-type)
+	  ;; (break "constant add: ~S" instruction)
+	  (make-load-constant (car (type-specifier-singleton result-type))
+			      destination funobj frame-map))
+	 ((and (movitz-subtypep type1 'fixnum)
+	       (movitz-subtypep type1 'fixnum)
+	       (movitz-subtypep result-type 'fixnum))
+	  (cond
+	   ((and (type-specifier-singleton type0)
+		 (eq loc1 destination))
+	    (cond
+	     ((member destination '(:eax :ebx :ecx :edx))
+	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+		       ,destination)))
+	     (t (assert (integerp loc1))
+		(break "check that this is correct..")
+		`((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+			 (:ebp ,(stack-frame-offset loc1)))))))
+	   (t (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A"
+		    destination loc0 loc1 type0 type1
+		    (type-specifier-singleton type0)
+		    (eq loc1 destination))
+	      (warn "ADDI: ~S" instruction)
+	      (append (cond
+		       ((and (eq :eax loc0) (eq :ebx loc1))
+			nil)
+		       ((and (eq :ebx loc0) (eq :eax loc1))
+			nil)		; terms order isn't important
+		       ((eq :eax loc1)
+			(append
+			 (make-load-lexical term0 :ebx funobj nil frame-map)))
+		       (t (append
+			   (make-load-lexical term0 :eax funobj nil frame-map)
+			   (make-load-lexical term1 :ebx funobj nil frame-map))))
+		      `((:movl (:edi ,(global-constant-offset '+)) :esi))
+		      (make-compiled-funcall-by-esi 2)
+		      (etypecase destination
+			(symbol
+			 (unless (eq destination :eax)
+			   `((:movl :eax ,destination))))
+			(binding
+			 (make-store-lexical destination :eax nil frame-map)))))))
+	 (t (append (cond
+		     ((and (eq :eax loc0) (eq :ebx loc1))
+		      nil)
+		     ((and (eq :ebx loc0) (eq :eax loc1))
+		      nil)		; terms order isn't important
+		     ((eq :eax loc1)
+		      (append
+		       (make-load-lexical term0 :ebx funobj nil frame-map)))
+		     (t (append
+			 (make-load-lexical term0 :eax funobj nil frame-map)
+			 (make-load-lexical term1 :ebx funobj nil frame-map))))
+		    `((:movl (:edi ,(global-constant-offset '+)) :esi))
+		    (make-compiled-funcall-by-esi 2)
+		    (etypecase destination
+		      (symbol
+		       (unless (eq destination :eax)
+			 `((:movl :eax ,destination))))
+		      (binding
+		       (make-store-lexical destination :eax nil frame-map))))))))))




From ffjeld at common-lisp.net  Sat Jul 10 13:29:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 10 Jul 2004 06:29:18 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BjHuo-0003Rm-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Re-working the compilation of addition. Now use a proper extended-code
instruction (which is like a "vop", I think).

Date: Sat Jul 10 06:29:18 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.24 movitz/special-operators.lisp:1.25
--- movitz/special-operators.lisp:1.24	Fri Jul  9 09:12:44 2004
+++ movitz/special-operators.lisp	Sat Jul 10 06:29:18 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.24 2004/07/09 16:12:44 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.25 2004/07/10 13:29:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1000,6 +1000,18 @@
       :forward all
       :env local-env
       :form sub-form)))
+
+(define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode)
+  (destructuring-bind (term1 term2)
+      (cdr form)
+    (let ((returns (ecase (result-mode-type result-mode)
+		     ((:function :multiple-values :eax :push) :eax)
+		     ((:ebx :ecx :edx) result-mode)
+		     ((:lexical-binding) result-mode))))
+      (compiler-values ()
+	:returns returns
+	:code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns))))))
+    
 
 (define-special-operator muerte::+%2op (&all all &form form &env env &result-mode result-mode)
   (assert (not (eq :boolean result-mode)) ()




From ffjeld at common-lisp.net  Sat Jul 10 13:29:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 10 Jul 2004 06:29:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BjHut-0003Ss-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Re-working the compilation of addition. Now use a proper extended-code
instruction (which is like a "vop", I think).

Date: Sat Jul 10 06:29:23 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.40 movitz/losp/muerte/integers.lisp:1.41
--- movitz/losp/muerte/integers.lisp:1.40	Thu Jul  8 14:51:08 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 10 06:29:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.40 2004/07/08 21:51:08 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -71,7 +71,10 @@
   (case (length operands)
     (0 0)
     (1 (first operands))
-    (2 `(+%2op ,(first operands) ,(second operands)))
+    #+ignore (2 `(+%2op ,(first operands) ,(second operands)))
+    (2 `(let ((x ,(first operands))
+	      (y ,(second operands)))
+	  (++%2op x y)))
     (t (let ((operands
 	      (loop for operand in operands
 		  if (movitz:movitz-constantp operand env)
@@ -1975,8 +1978,9 @@
 	 (movitz:movitz-eval integer env))) ; constant folding
    ((and (movitz:movitz-constantp size env)
 	 (movitz:movitz-constantp position env))
-    (let ((size (movitz:movitz-eval size env))
-	  (position (movitz:movitz-eval position env)))
+    (let* ((size (movitz:movitz-eval size env))
+	   (position (movitz:movitz-eval position env))
+	   (result-type `(unsigned-byte ,size)))
       (cond
        ((or (minusp size) (minusp position))
 	(error "Negative byte-spec for ldb."))
@@ -1984,7 +1988,7 @@
 	`(progn ,integer 0))
        ((<= (+ size position) (- 31 movitz:+movitz-fixnum-shift+))
 	`(with-inline-assembly (:returns :register
-					 :type (integer 0 ,(mask-field (byte size 0) -1)))
+					 :type ,result-type)
 	   (:compile-form (:result-mode :eax) ,integer)
 	   (:call-global-constant unbox-u32)
 	   (:andl ,(mask-field (byte size position) -1) :ecx)
@@ -1992,7 +1996,7 @@
 	       `((:shrl ,position :ecx)))
 	   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) (:result-register))))
        ((<= (+ size position) 32)
-	`(with-inline-assembly-case ()
+	`(with-inline-assembly-case (:type ,result-type)
 	   (do-case (t :eax :labels (nix done))
 	     (:compile-form (:result-mode :eax) ,integer)
 	     ,@(cond




From ffjeld at common-lisp.net  Sat Jul 10 14:39:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 10 Jul 2004 07:39:29 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BjJ0j-0001iG-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Implemented  addition of negative fixnums and positive bignums.

Date: Sat Jul 10 07:39:28 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.41 movitz/losp/muerte/integers.lisp:1.42
--- movitz/losp/muerte/integers.lisp:1.41	Sat Jul 10 06:29:23 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 10 07:39:28 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.42 2004/07/10 14:39:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,6 +28,9 @@
 (deftype positive-bignum ()
   `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *))
 
+(deftype negative-fixnum ()
+  `(integer ,movitz:+movitz-most-negative-fixnum+ -1))
+
 (defmacro number-double-dispatch ((x y) &rest clauses)
   `(let ((x ,x) (y ,y))
      (cond ,@(loop for ((x-type y-type) . then-body) in clauses
@@ -123,7 +126,13 @@
 		((positive-bignum positive-fixnum)
 		 (funcall '+ y x))
 		((positive-fixnum positive-bignum)
-		 (with-inline-assembly (:returns :eax)
+		 (with-inline-assembly (:returns :eax :labels (retry-not-size1
+							       not-size1
+							       copy-bignum-loop
+							       add-bignum-loop
+							       add-bignum-done
+							       no-expansion
+							       pfix-pbig-done))
 		   (:compile-two-forms (:eax :ebx) y x)
 		   (:testl :ebx :ebx)
 		   (:jz 'pfix-pbig-done)
@@ -131,7 +140,7 @@
 		   (:cmpl 1 :ecx)
 		   (:jne 'not-size1)
 		   (:compile-form (:result-mode :ecx) x)
-		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
 		   (:jc 'retry-not-size1)
 		   (:call-global-constant box-u32-ecx)
@@ -160,7 +169,7 @@
 		   (:jnz 'copy-bignum-loop)
 
 		   (:load-lexical (:lexical-binding x) :ecx)
-		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:xorl :ebx :ebx)
 		   (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 		   (:jnc 'add-bignum-done)
@@ -177,6 +186,70 @@
 		   (:je 'no-expansion)
 		   (:addl #x10000 (:eax ,movitz:+other-type-offset+))
 		   (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+		  no-expansion
+		   (:call-global-constant cons-commit)
+		   (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+				    (:edi (:edi-offset atomically-status))))
+		   
+		  pfix-pbig-done))
+		((negative-fixnum positive-bignum)
+		 (with-inline-assembly (:returns :eax :labels (retry-not-size1
+							       not-size1
+							       copy-bignum-loop
+							       add-bignum-loop
+							       add-bignum-done
+							       no-expansion
+							       pfix-pbig-done))
+		   (:compile-two-forms (:eax :ebx) y x)
+		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:cmpl 1 :ecx)
+		   (:jne 'not-size1)
+		   (:compile-form (:result-mode :ecx) x)
+		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		   (:call-global-constant box-u32-ecx)
+		   (:jmp 'pfix-pbig-done)
+		  retry-not-size1
+		   (:compile-form (:result-mode :eax) y)
+		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		  not-size1
+		   (:declare-label-set retry-jumper (retry-not-size1))
+		   (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
+		   (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
+				      'retry-jumper)
+				    (:edi (:edi-offset atomically-status))))
+		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 1 movitz:+movitz-fixnum-factor+))
+			  :eax)		; Number of words
+		   (:call-global-constant get-cons-pointer)
+		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
+		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+			  :edx)
+		  copy-bignum-loop
+		   (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+		   (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
+		   (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
+		   (:jnz 'copy-bignum-loop)
+
+		   (:load-lexical (:lexical-binding x) :ecx)
+		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:xorl :ebx :ebx)	; counter
+		   (:negl :ecx)
+		   (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:jnc 'add-bignum-done)
+		  add-bignum-loop
+		   (:addl 4 :ebx)
+		   (:subl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:jc 'add-bignum-loop)
+		  add-bignum-done
+		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			    :ecx)
+		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+			  :ecx)		; result bignum word-size
+		   (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		   (:jne 'no-expansion)
+		   (:subl #x10000 (:eax ,movitz:+other-type-offset+))
+		   (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
 		   (:call-global-constant cons-commit)
 		   (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)




From ffjeld at common-lisp.net  Sun Jul 11 19:26:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 12:26:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1Bjjxk-0001L6-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv4896

Modified Files:
	debugger.lisp 
Log Message:
When filtering out conditions in safe-print-stack-frame-arglist, only
catch serious-conditions.

Date: Sun Jul 11 12:26:12 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.13 movitz/losp/x86-pc/debugger.lisp:1.14
--- movitz/losp/x86-pc/debugger.lisp:1.13	Thu Jun 10 09:28:27 2004
+++ movitz/losp/x86-pc/debugger.lisp	Sun Jul 11 12:26:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.13 2004/06/10 16:28:27 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.14 2004/07/11 19:26:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -429,7 +429,7 @@
 (defun safe-print-stack-frame-arglist (&rest args)
   (declare (dynamic-extent args))
   (handler-case (apply #'print-stack-frame-arglist args)
-    (t (conditon)
+    (serious-condition (conditon)
       (write-string "#<error printing frame>"))))
 
 (defun backtrace (&key ((:frame initial-stack-frame)




From ffjeld at common-lisp.net  Sun Jul 11 22:47:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 15:47:10 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <E1Bjn6E-00061A-00@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Removed buggy implementation of replace between two u32 vectors.

Date: Sun Jul 11 15:47:10 2004
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.14 movitz/losp/muerte/sequences.lisp:1.15
--- movitz/losp/muerte/sequences.lisp:1.14	Thu Jul  8 04:30:36 2004
+++ movitz/losp/muerte/sequences.lisp	Sun Jul 11 15:47:10 2004
@@ -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.14 2004/07/08 11:30:36 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.15 2004/07/11 22:47:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -735,11 +735,6 @@
 	       (memcopy sequence-1 sequence-2 2 start1 start2
 			(min (- end1 start1) (- end2 start2))
 			:unsigned-byte8))
-	      ((:u32 :u32)
-	       (%copy-words (object-location sequence-1)
-			    (object-location sequence-2)
-			    (min (- end1 start1) (- end2 start2))
-			    start1 start2))
 	      (t (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
 		   (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
 		     (cond




From ffjeld at common-lisp.net  Sun Jul 11 22:58:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 15:58:56 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BjnHc-0007vi-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed a nasty compiler bug. Function arguments located on the
argument-stack would not be treated properly, e.g when copying one
such variable to another.

Date: Sun Jul 11 15:58:56 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.72 movitz/compiler.lisp:1.73
--- movitz/compiler.lisp:1.72	Sat Jul 10 06:29:11 2004
+++ movitz/compiler.lisp	Sun Jul 11 15:58:56 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.72 2004/07/10 13:29:11 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.73 2004/07/11 22:58:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2399,7 +2399,10 @@
 	      (list new-value)
 	      `(let ((,(car stores) (progn
 				      (assert (not (new-binding-located-p ,binding-var ,getter)))
-				      (check-type ,new-value (or keyword binding (integer 0 *)))
+				      (check-type ,new-value (or keyword
+								 binding
+								 (integer 0 *)
+								 (cons (eql :argument-stack) *)))
 				      (acons ,binding-var ,new-value ,getter))))
 		 ,setter
 		 ,new-value)
@@ -2813,7 +2816,7 @@
 					 (plusp (or (car (gethash binding var-counts)) 0)))
 				    (prog1 nil ; may need lending-cons
 				      (setf (new-binding-location binding frame-map)
-					:argument-stack)))
+					`(:argument-stack ,(function-argument-argnum binding)))))
 				   ((not (plusp (or (car (gethash binding var-counts)) 0)))
 				    (prog1 t
 				      (unless (or (movitz-env-get variable 'ignore nil env nil)
@@ -2949,7 +2952,7 @@
 		       (borrowed-binding) ; location is predetermined
 		       (fixed-required-function-argument
 			(setf (new-binding-location binding frame-map)
-			  :argument-stack))
+			  `(:argument-stack ,(function-argument-argnum binding))))
 		       (located-binding
 			(setf (new-binding-location binding frame-map)
 			  (post-incf stack-frame-position))))))
@@ -3228,7 +3231,7 @@
 		       (when indirect-p
 			 `((:movl (-1 ,(single-value-register result-mode))
 				  ,(single-value-register result-mode))))))
-	      (t (ecase lexb-location
+	      (t (ecase (operator lexb-location)
 		   (:push
 		    (assert (member result-mode '(:eax :ebx :ecx :edx)))
 		    (assert (not indirect-p))
@@ -3324,7 +3327,7 @@
 		(if (integerp binding-location)
 		    `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax)
 		      (:pushl (:eax -1)))
-		  (ecase binding-location
+		  (ecase (operator binding-location)
 		    (:argument-stack
 		     (assert (<= 2 (function-argument-argnum binding)) ()
 		       ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
@@ -3340,7 +3343,7 @@
 		 (:push
 		  (if (integerp binding-location)
 		      `((:pushl (:ebp ,(stack-frame-offset binding-location))))
-		    (ecase binding-location
+		    (ecase (operator binding-location)
 		      ((:eax :ebx :ecx :edx)
 		       `((:pushl ,binding-location)))
 		      (:argument-stack
@@ -3351,7 +3354,7 @@
 		  (if (integerp binding-location)
 		      `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
 			(:jne ',(operands result-mode)))
-		    (ecase binding-location
+		    (ecase (operator binding-location)
 		      ((:eax :ebx)
 		       `((:cmpl :edi ,binding-location)
 			 (:jne ',(operands result-mode))))
@@ -3362,7 +3365,7 @@
 		  (if (integerp binding-location)
 		      `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
 			(:je ',(operands result-mode)))
-		    (ecase binding-location
+		    (ecase (operator binding-location)
 		      ((:eax :ebx)
 		       `((:cmpl :edi ,binding-location)
 			 (:je ',(operands result-mode))))
@@ -3378,7 +3381,7 @@
 		     ((not dest-location) ; unknown, e.g. a borrowed-binding.
 		      (append (install-for-single-value binding binding-location :ecx nil)
 			      (make-store-lexical result-mode :ecx nil frame-map)))
-		     ((eql binding-location dest-location)
+		     ((equal binding-location dest-location)
 		      nil)
 		     ((member binding-location '(:eax :ebx :ecx :edx))
 		      (make-store-lexical destination binding-location nil frame-map))
@@ -3435,7 +3438,7 @@
 	(if (integerp location)
 	    `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
 	      (:movl ,source (,tmp-reg -1)))
-	  (ecase location
+	  (ecase (operator location)
 	    (:argument-stack
 	     (assert (<= 2 (function-argument-argnum binding)) ()
 	       "store-lexical argnum can't be ~A." (function-argument-argnum binding))
@@ -3444,7 +3447,7 @@
      (t (let ((location (new-binding-location binding frame-map)))
 	  (if (integerp location)
 	      `((:movl ,source (:ebp ,(stack-frame-offset location))))
-	    (ecase location
+	    (ecase (operator location)
 	      ((:push)
 	       `((:pushl ,source)))
 	      ((:eax :ebx :ecx :edx)
@@ -4091,7 +4094,7 @@
 		  (typecase binding
 		    (required-function-argument
 		     ;; (warn "lend: ~W => ~W" binding lended-cons-position)
-		     (etypecase location
+		     (etypecase (operator location)
 		       ((eql :eax)
 			(warn "lending EAX..")
 			`((:movl :edi
@@ -4123,7 +4126,7 @@
 				 (:ebp ,(stack-frame-offset location)))))))
 		    (closure-binding
 		     ;; (warn "lend closure-binding: ~W => ~W" binding lended-cons-position)
-		     (etypecase location
+		     (etypecase (operator location)
 		       ((eql :argument-stack)
 			`((:movl (:edi ,(global-constant-offset 'unbound-function)) :edx)
 			  (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr




From ffjeld at common-lisp.net  Sun Jul 11 22:59:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 15:59:26 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1BjnI6-0002FA-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
More symbols.

Date: Sun Jul 11 15:59:26 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.29 movitz/packages.lisp:1.30
--- movitz/packages.lisp:1.29	Thu Jul  8 11:53:29 2004
+++ movitz/packages.lisp	Sun Jul 11 15:59:26 2004
@@ -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.29 2004/07/08 18:53:29 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.30 2004/07/11 22:59:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1101,6 +1101,7 @@
 	   print-word
 	   fixnump below
 	   print-unreadable-movitz-object
+	   #:newline
 	   
 	   #:*print-safely*
 	   
@@ -1159,6 +1160,7 @@
 	   svref%unsafe
 	   bvref-u16
 	   object-location
+	   object-tag
 	   location-in-object-p
 	   inline-malloc
 	   define-compile-time-variable




From ffjeld at common-lisp.net  Sun Jul 11 23:00:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 16:00:41 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BjnJJ-0000Si-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Fixed (setf memref) for type :unsigned-byte32, which was completely
bogus before.

Date: Sun Jul 11 16:00:41 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.14 movitz/losp/muerte/memref.lisp:1.15
--- movitz/losp/muerte/memref.lisp:1.14	Sun Jun  6 04:32:09 2004
+++ movitz/losp/muerte/memref.lisp	Sun Jul 11 16:00:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.14 2004/06/06 11:32:09 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.15 2004/07/11 23:00:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -326,12 +326,16 @@
 		(:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
 	      ,value)))
 	((movitz:movitz-constantp offset env)
-	 (let ((value-var (gensym "memref-value-")))
-	   `(let ((,value-var ,value))
+	 (let ((value-var (gensym "memref-value-"))
+	       (object-var (gensym "memref-object-"))
+	       (index-var (gensym "memref-index-")))
+	   `(let ((,value-var ,value)
+		  (,object-var ,object)
+		  (,index-var ,index))
 	      (with-inline-assembly (:returns :untagged-fixnum-ecx)
-		(:compile-two-forms (:ebx :eax) ,object ,index)
-		(:load-lexical (:lexical-binding ,value-var) :ecx)
-		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:load-lexical (:lexical-binding ,value-var) :eax)
+		(:call-global-constant unbox-u32)
+		(:compile-two-forms (:ebx :eax) ,object-var ,index-var)
 		(:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env)))))))
 	(t (let ((value-var (gensym "memref-value-"))
 		 (object-var (gensym "memref-object-"))
@@ -342,14 +346,16 @@
 		    (,object-var ,object)
 		    (,offset-var ,offset)
 		    (,index-var ,index))
-		(with-inline-assembly (:returns :eax)
-		  (:compile-two-forms (:edx :untagged-fixnum-ecx) ,index-var ,offset-var)
-		  (:addl :edx :ecx)	; offset+index in ECX
-		  (:compile-two-forms (:eax :ebx) ,value-var ,object-var)
+		(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		  (:load-lexical (:lexical-binding ,value-var) :eax)
+		  (:call-global-constant unbox-u32)
+		  (:compile-two-forms (:eax :edx) ,index-var ,offset-var)
+		  (:load-lexical (:lexical-binding ,object-var) :ebx)
 		  (:std)
-		  (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
-		  (:movl :eax (:ebx :ecx))
-		  (:shll ,movitz:+movitz-fixnum-shift+ :eax)
+		  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+		  (:addl :eax :edx) ; EDX = offset+index
+		  (:movl :ecx (:ebx :edx))
+		  (:movl :edi :edx)
 		  (:cld)))))))
       (:unsigned-byte16
        (cond




From ffjeld at common-lisp.net  Sun Jul 11 23:02:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 16:02:33 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BjnL7-0003Jf-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed a nasty bug in (setf aref) for u32 vectors.

Date: Sun Jul 11 16:02:33 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.34 movitz/losp/muerte/arrays.lisp:1.35
--- movitz/losp/muerte/arrays.lisp:1.34	Thu Jul  8 14:51:48 2004
+++ movitz/losp/muerte/arrays.lisp	Sun Jul 11 16:02:33 2004
@@ -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.34 2004/07/08 21:51:48 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.35 2004/07/11 23:02:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -337,7 +337,7 @@
 		   (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
 		   (:jne 'not-u32-vector)
 		   (:call-global-constant unbox-u32)
-		   (:movl :eax
+		   (:movl :ecx
 			  (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 		   (:jmp 'return)
 
@@ -628,7 +628,7 @@
       (setf (fill-pointer array) length)))
     (cond
      (initial-element
-      (check-type initial-element (unsigned-byte 8))
+      (check-type initial-element bit)
       (dotimes (i length)
 	(setf (aref array i) initial-element)))
      (initial-contents




From ffjeld at common-lisp.net  Sun Jul 11 23:03:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 16:03:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1BjnLq-00041N-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Added operator object-tag.

Date: Sun Jul 11 16:03:18 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.11 movitz/losp/muerte/basic-functions.lisp:1.12
--- movitz/losp/muerte/basic-functions.lisp:1.11	Fri Apr 16 12:25:06 2004
+++ movitz/losp/muerte/basic-functions.lisp	Sun Jul 11 16:03:18 2004
@@ -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.11 2004/04/16 19:25:06 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.12 2004/07/11 23:03:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -340,6 +340,16 @@
 (defun object-location (object)
   "The location is the object's address divided by fixnum-factor."
   (object-location object))
+
+(define-compiler-macro object-tag (object)
+  `(with-inline-assembly (:returns :register :type (integer 0 7))
+     (:compile-form (:result-mode :register) ,object)
+     (:leal (((:result-register) ,movitz::+movitz-fixnum-factor+))
+	    (:result-register))
+     (:andl ,(* 7 movitz::+movitz-fixnum-factor+) (:result-register))))
+
+(defun object-tag (object)
+  (object-tag object))
 
 ;;;(define-compiler-macro object-location-offset (object)
 ;;;  "The offset from the object's location to it's true address."




From ffjeld at common-lisp.net  Sun Jul 11 23:04:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 16:04:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BjnMk-0007kX-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Include the :label argumet for with-inline-assembly.

Date: Sun Jul 11 16:04:14 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.25 movitz/losp/muerte/basic-macros.lisp:1.26
--- movitz/losp/muerte/basic-macros.lisp:1.25	Wed Jul  7 10:37:30 2004
+++ movitz/losp/muerte/basic-macros.lisp	Sun Jul 11 16:04:14 2004
@@ -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.25 2004/07/07 17:37:30 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.26 2004/07/11 23:04:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -966,9 +966,9 @@
   `(progn , at body))
 
 
-(defmacro with-inline-assembly ((&key returns (side-effects t) (type t)) &body program)
+(defmacro with-inline-assembly ((&key returns (side-effects t) (type t) labels) &body program)
   `(with-inline-assembly-case (:side-effects ,side-effects :type ,type)
-     (do-case (t ,returns)
+     (do-case (t ,returns :labels ,labels)
        , at program)))
 
 (defmacro numargs-case (&rest args)




From ffjeld at common-lisp.net  Sun Jul 11 23:05:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 11 Jul 2004 16:05:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BjnNs-0001Y0-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed logand and logior for bignums.

Date: Sun Jul 11 16:05:24 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.42 movitz/losp/muerte/integers.lisp:1.43
--- movitz/losp/muerte/integers.lisp:1.42	Sat Jul 10 07:39:28 2004
+++ movitz/losp/muerte/integers.lisp	Sun Jul 11 16:05:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.42 2004/07/10 14:39:28 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.43 2004/07/11 23:05:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1469,35 +1469,29 @@
 	 (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax)))))
 
       
-(defun logand%2op (x y)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) x)
-    (:compile-form (:result-mode :ebx) y)
-    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-    (:jnz '(:sub-program () (:int 107)))
-    (:testb #.movitz::+movitz-fixnum-zmask+ :bl)
-    (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107)))
-    (:andl :ebx :eax)))
-
-(define-compiler-macro logand%2op (&whole form x y)
-  (cond
-   ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y))
-    (logand  (movitz::movitz-eval x) (movitz::movitz-eval y)))
-   (t form)))
-
-(defun logand (&rest integers)
-  (declare (dynamic-extent integers))
-  (if (null integers)
-      -1
-    (reduce #'logand%2op integers)))
+;;;(defun logand%2op (x y)
+;;;  (with-inline-assembly (:returns :eax)
+;;;    (:compile-form (:result-mode :eax) x)
+;;;    (:compile-form (:result-mode :ebx) y)
+;;;    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
+;;;    (:jnz '(:sub-program () (:int 107)))
+;;;    (:testb #.movitz::+movitz-fixnum-zmask+ :bl)
+;;;    (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107)))
+;;;    (:andl :ebx :eax)))
+;;;
+;;;(define-compiler-macro logand%2op (&whole form x y)
+;;;  (cond
+;;;   ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y))
+;;;    (logand  (movitz::movitz-eval x) (movitz::movitz-eval y)))
+;;;   (t form)))
 
-(define-compiler-macro logand (&whole form &rest integers)
+(define-compiler-macro logand (&whole form &rest integers &environment env)
   (let ((constant-folded-integers (loop for x in integers
 				      with folded-constant = -1
-				      if (and (movitz:movitz-constantp x)
-					      (not (= -1 (movitz::movitz-eval x))))
+				      if (and (movitz:movitz-constantp x env)
+					      (not (= -1 (movitz:movitz-eval x env))))
 				      do (setf folded-constant
-					   (logand folded-constant (movitz::movitz-eval x)))
+					   (logand folded-constant (movitz:movitz-eval x env)))
 				      else collect x into non-constants
 				      finally (return (if (= -1 folded-constant)
 							  non-constants
@@ -1505,10 +1499,59 @@
     (case (length constant-folded-integers)
       (0 0)
       (1 (first constant-folded-integers))
-      (2 `(logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers)))
-      (t `(logand (logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers))
+      (2 `(no-macro-call logand ,(first constant-folded-integers) ,(second constant-folded-integers)))
+      (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers))
 		  ,@(cddr constant-folded-integers))))))
 
+(defun logand (&rest integers)
+  (numargs-case
+   (1 (x) x)
+   (2 (x y)
+      (macrolet
+	  ((do-it ()
+	     `(number-double-dispatch (x y)
+		((fixnum fixnum)
+		 (with-inline-assembly (:returns :eax)
+		   (:compile-two-forms (:eax :ebx) x y)
+		   (:andl :ebx :eax)))
+		((positive-bignum positive-fixnum)
+		 (with-inline-assembly (:returns :eax)
+		   (:compile-form (:result-mode :eax) x)
+		   (:call-global-constant unbox-u32)
+		   (:compile-form (:result-mode :eax) y)
+		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx)
+		   (:andl :ecx :eax)))
+		((positive-fixnum positive-bignum)
+		 (with-inline-assembly (:returns :eax)
+		   (:compile-form (:result-mode :eax) y)
+		   (:call-global-constant unbox-u32)
+		   (:compile-form (:result-mode :eax) x)
+		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx)
+		   (:andl :ecx :eax)))
+		((positive-bignum positive-bignum)
+		 (if (< (%bignum-bigits y) (%bignum-bigits x))
+		     (logand y x)
+		   (%bignum-canonicalize
+		    (with-inline-assembly (:returns :eax)
+		      (:compile-two-forms (:eax :ebx) (copy-bignum x) y)
+		      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			       :ecx)
+		      (:leal ((:ecx 4) -4) :edx)
+		     pb-pb-and-loop
+		      (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			     :ecx)
+		      (:andl :ecx
+			     (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		      (:subl 4 :edx)
+		      (:jnc 'pb-pb-and-loop)))))
+		)))
+	(do-it)))
+   (t (&rest integers)
+      (declare (dynamic-extent integers))
+      (if (null integers)
+	  -1
+	(reduce #'logand integers)))))
+
 (defun logandc1 (integer1 integer2)
   (number-double-dispatch (integer1 integer2)
     ((t positive-fixnum)
@@ -1518,34 +1561,10 @@
        (:shll #.movitz:+movitz-fixnum-shift+ :ecx)
        (:compile-form (:result-mode :eax) integer2)
        (:notl :ecx)
-       (:andl :ecx :eax)))
-    ((positive-fixnum t)
-     (with-inline-assembly (:returns :eax)
-       (:compile-form (:result-mode :eax) integer2)
-       (:call-global-constant unbox-u32)
-       (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax)
-       (:compile-form (:result-mode :ecx) integer1)
-       (:notl :ecx)
        (:andl :ecx :eax)))))
 
 (defun logandc2 (integer1 integer2)
-  (number-double-dispatch (integer1 integer2)
-    ((positive-fixnum t)
-     (with-inline-assembly (:returns :eax)
-       (:compile-form (:result-mode :eax) integer2)
-       (:call-global-constant unbox-u32)
-       (:shll #.movitz:+movitz-fixnum-shift+ :ecx)
-       (:compile-form (:result-mode :eax) integer1)
-       (:notl :ecx)
-       (:andl :ecx :eax)))
-    ((t positive-fixnum)
-     (with-inline-assembly (:returns :eax)
-       (:compile-form (:result-mode :eax) integer1)
-       (:call-global-constant unbox-u32)
-       (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax)
-       (:compile-form (:result-mode :ecx) integer2)
-       (:notl :ecx)
-       (:andl :ecx :eax)))))
+  (logandc1 integer2 integer1))
 
 (defun logior (&rest integers)
   (numargs-case
@@ -1633,20 +1652,20 @@
 	((positive-fixnum positive-bignum)
 	 (macrolet
 	     ((do-it ()
-		`(let ((r (copy-bignum y)))
-		   (with-inline-assembly (:returns :eax)
-		     (:compile-two-forms (:eax :ecx) r x)
-		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		     (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx)))))
+		`(with-inline-assembly (:returns :eax)
+		   (:compile-two-forms (:eax :ecx) (copy-bignum y) x)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:xorl :ecx
+			  (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))
 	   (do-it)))
 	((positive-bignum positive-fixnum)
 	 (macrolet
 	     ((do-it ()
-		`(let ((r (copy-bignum x)))
-		   (with-inline-assembly (:returns :eax)
-		     (:compile-two-forms (:eax :ecx) r y)
-		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		     (:xorl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))))
+		`(with-inline-assembly (:returns :eax)
+		   (:compile-two-forms (:eax :ecx) (copy-bignum x) y)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:xorl :ecx
+			  (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))
 	   (do-it)))
 	((positive-bignum positive-bignum)
 	 (if (< (%bignum-bigits x) (%bignum-bigits y))




From ffjeld at common-lisp.net  Mon Jul 12 07:54:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 00:54:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1Bjvdu-0005FY-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
Added condition  "newline".

Date: Mon Jul 12 00:54:30 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.7 movitz/losp/muerte/conditions.lisp:1.8
--- movitz/losp/muerte/conditions.lisp:1.7	Thu Jun 10 05:07:02 2004
+++ movitz/losp/muerte/conditions.lisp	Mon Jul 12 00:54:30 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.7 2004/06/10 12:07:02 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.8 2004/07/12 07:54:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -303,3 +303,5 @@
 	     (or format-control "Break was invoked.")
 	     format-arguments)))
   nil)
+
+(define-condition newline () ())




From ffjeld at common-lisp.net  Mon Jul 12 07:56:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 00:56:45 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1Bjvg5-0001kO-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Tweaks to map-heap-words, added some invariant assertions.

Date: Mon Jul 12 00:56:45 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.13 movitz/losp/muerte/scavenge.lisp:1.14
--- movitz/losp/muerte/scavenge.lisp:1.13	Wed Jul  7 10:37:25 2004
+++ movitz/losp/muerte/scavenge.lisp	Mon Jul 12 00:56:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.13 2004/07/07 17:37:25 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.14 2004/07/12 07:56:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,6 +27,7 @@
 ;; circumstances, i.e. when you know there is no outside GC
 ;; etc. involved.
 
+(defvar *scan*)
 
 (defun map-heap-words (function start-location end-location)
   "Map function over each potential pointer word between
@@ -49,11 +50,13 @@
 		  (:compile-form (:result-mode :eax) ,x)
 		  (:andl #xffff0000 :eax)
 		  (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax))))
-    (do ((scan start-location (1+ scan)))
+    (do ((*scan-last* nil)		; Last scanned object, for debugging.
+	 (scan start-location (1+ scan)))
 	((>= scan end-location))
-      (let (;; (*i* i)
+      (declare (special *scan-last*))
+      (let ((*scan* scan)
 	    (x (memref scan 0 0 :lisp)))
-	;; (declare (special *i*))
+	(declare (special *scan*))
 	(cond
 	 ((typep x '(or null fixnum character)))
 	 ((scavenge-typep x :illegal)
@@ -64,10 +67,12 @@
 	  ;; Just skip the bigits
 	  (let* ((bigits (word-upper16 x))
 		 (delta (1+ (logand bigits -2))))
+	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan delta)))
 	 ((scavenge-typep x :funobj)
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
+	  (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	  ;; Process code-vector pointer specially..
 	  (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
 		 (code-vector (funobj-code-vector funobj))
@@ -86,8 +91,6 @@
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location))
-	 ((scavenge-typep x :old-vector)
-	  (error "Scanned old-vector #x~Z at odd address #x~X." x scan))
 	 ((or (scavenge-wide-typep x :basic-vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
 	      (scavenge-wide-typep x :basic-vector
@@ -97,18 +100,29 @@
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
-	    ;; (warn "scavenge at #x~X u8 vector len ~D." scan len)
+	    (check-type len positive-fixnum)
+	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
+	    (check-type len positive-fixnum)
+	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
+	    (check-type len positive-fixnum)
+	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (logand (1+ len) -2)))))
+	 ((and (scavenge-typep x :basic-vector)
+	       (not (scavenge-wide-typep x :basic-vector
+					 #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t))))
+	  (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan))
+	 ((scavenge-typep x :old-vector)
+	  (error "Scanned old-vector #x~Z at address #x~X." x scan))
 	 ((eq x (fixnum-word 3))
 	  (incf scan)
 	  (incf scan (memref scan 0 0 :lisp)))




From ffjeld at common-lisp.net  Mon Jul 12 07:57:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 00:57:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <E1BjvhA-0002kW-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv10562

Modified Files:
	textmode.lisp 
Log Message:
Added the idea that condition "newline" is signalled whenever the
console scrolls down. This can be used e.g. to implement :more in los0.lisp.

Date: Mon Jul 12 00:57:52 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.6 movitz/losp/x86-pc/textmode.lisp:1.7
--- movitz/losp/x86-pc/textmode.lisp:1.6	Wed Apr 21 09:24:10 2004
+++ movitz/losp/x86-pc/textmode.lisp	Mon Jul 12 00:57:52 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.6 2004/04/21 16:24:10 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.7 2004/07/12 07:57:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -69,12 +69,12 @@
 (defun textmode-write-char (c)
   (case c
     (#\newline
-     (setf *cursor-x* 0)
      (cond
       ((>= (1+ *cursor-y*) *screen-height*)
        (textmode-scroll-down)
        (setf *cursor-y* (1- *screen-height*)))
       (t (incf *cursor-y*)))
+     (setf *cursor-x* 0)
      (move-vga-cursor 0 *cursor-y*))
     (#\backspace
      (if (/= 0 *cursor-x*)
@@ -125,6 +125,7 @@
 
 (defun textmode-scroll-down ()
   (declare (special muerte.lib::*scroll-offset*))
+  (signal 'newline)
   (incf muerte.lib::*scroll-offset*)
   (loop with stride = (* 2 *screen-stride*)
       for y below *screen-height*




From ffjeld at common-lisp.net  Mon Jul 12 07:59:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 00:59:04 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BjviK-0006AS-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Added some (commented out) debugging code to stop-and-copy.

Date: Mon Jul 12 00:59:04 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.21 movitz/losp/los0-gc.lisp:1.22
--- movitz/losp/los0-gc.lisp:1.21	Thu Jul  8 11:59:51 2004
+++ movitz/losp/los0-gc.lisp	Mon Jul 12 00:59:04 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.21 2004/07/08 18:59:51 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.22 2004/07/12 07:59:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -54,8 +54,8 @@
     (setf (space-other space1) space2)
     space1))
 
-(defun space-cons-pointer ()
-  (aref (%run-time-context-slot 'nursery-space) 0))
+;;;(defun space-cons-pointer ()
+;;;  (aref (%run-time-context-slot 'nursery-space) 0))
 
 (defun test ()
   (warn "install..")
@@ -329,8 +329,11 @@
       (map-stack-words #'zap-oldspace (current-stack-frame))
       (initialize-space oldspace)
       (values))))
-  
+
+(defparameter *x* #500())
+
 (defun stop-and-copy (&optional evacuator)
+  (setf (fill-pointer *x*) 0)
   (let* ((space0 (%run-time-context-slot 'nursery-space))
 	 (space1 (space-other space0)))
     (check-type space0 vector-u32)
@@ -349,14 +352,29 @@
 		 (lambda (x location)
 		   "If x is in oldspace, migrate it to newspace."
 		   (declare (ignore location))
-		   (if (not (object-in-space-p oldspace x))
-		       x
-		     (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))
-		       (if (object-in-space-p newspace forwarded-x)
-			   forwarded-x
-			 (let ((forward-x (shallow-copy x)))
-			   (setf (memref (object-location x) 0 1 :lisp) forward-x)
-			   forward-x))))))))
+		   (cond
+		    ((not (object-in-space-p oldspace x))
+		     x)
+		    #+ignore
+		    ((typep x 'muerte::tag6)
+		     (let ((fwi (position (object-location x) *x* :test #'eq)))
+		       (if fwi
+			   (muerte::%word-offset (aref *x* (1+ fwi)) 6)
+			 (let ((fw (shallow-copy x)))
+			   (vector-push (object-location x) *x*)
+			   (vector-push (object-location fw) *x*)
+			   fw))))
+		    (t (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))
+			 (if (object-in-space-p newspace forwarded-x)
+			     (progn
+			       (assert (eq (object-tag forwarded-x)
+					   (object-tag x)))
+			       forwarded-x)
+			   (let ((forward-x (shallow-copy x)))
+			     (when (typep x 'muerte::bignum)
+			       (assert (= x forward-x)))
+			     (setf (memref (object-location x) 0 1 :lisp) forward-x)
+			     forward-x)))))))))
 	;; Scavenge roots
 	(map-heap-words evacuator 0 (+ (malloc-buffer-start)
 				       (* 2 (malloc-cons-pointer))))
@@ -370,6 +388,17 @@
 			       (+ newspace-location scan-pointer)
 			       (+ newspace-location (space-fresh-pointer newspace)))
 	       (setf scan-pointer fresh-pointer))
+
+	(dotimes (i (truncate (length *x*) 2))
+	  (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6))
+		(y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6)))
+	    (assert (and (object-in-space-p newspace y)
+			 (object-in-space-p oldspace x)
+			 (or (typep x 'muerte::std-instance)
+			     (equalp x y)))
+		()
+	      "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace)))
+
 	;; GC completed, oldspace is evacuated.
 	(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
 	      (new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))




From ffjeld at common-lisp.net  Mon Jul 12 08:00:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 01:00:06 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1BjvjK-0003CF-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Added with-paging macro (should be in lib?) and :more
top-level-command. Try :more <form> in REPL.

Date: Mon Jul 12 01:00:06 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.16 movitz/losp/los0.lisp:1.17
--- movitz/losp/los0.lisp:1.16	Thu Jul  8 14:52:29 2004
+++ movitz/losp/los0.lisp	Mon Jul 12 01:00:06 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.16 2004/07/08 21:52:29 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.17 2004/07/12 08:00:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -805,6 +805,32 @@
       (dolist (x cl:/ (values-list cl:/))
 	(do-print x)))))
 
+(defmacro with-paging (options &body body)
+  (declare (ignore options))
+  `(block paging
+     (let ((*paging-offset* 2))
+       (handler-bind
+	   ((newline (lambda (condition)
+		       (declare (ignore condition))
+		       (when (>= (incf *paging-offset*)
+				 muerte.x86-pc::*screen-height*)
+			 (format t "~&more? ")
+			 (loop
+			   (case (muerte.x86-pc.keyboard:poll-char)
+			     ((#\esc #\n #\N)
+			      (return-from paging (values)))
+			     ((#\y #\Y #\space #\newline)
+			      (setf *paging-offset* 1)
+			      (return))))))))
+	 , at body))))
+
+(defun tp (x) (dotimes (i x) (print i)))
+
+(define-toplevel-command :more (form)
+  (with-paging ()
+    (multiple-value-call #'format t "~@{~&~W~}"
+			 (eval form))))
+	 
 (define-toplevel-command :pop ()
   (when *debugger-dynamic-context*
     (let ((r (find-restart-from-context 'abort *debugger-dynamic-context*)))




From ffjeld at common-lisp.net  Mon Jul 12 08:41:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 01:41:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1BjwNH-0006KV-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Tweaked the implementation of :more.

Date: Mon Jul 12 01:41:23 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.17 movitz/losp/los0.lisp:1.18
--- movitz/losp/los0.lisp:1.17	Mon Jul 12 01:00:06 2004
+++ movitz/losp/los0.lisp	Mon Jul 12 01:41:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.17 2004/07/12 08:00:06 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.18 2004/07/12 08:41:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -808,20 +808,32 @@
 (defmacro with-paging (options &body body)
   (declare (ignore options))
   `(block paging
-     (let ((*paging-offset* 2))
+     (let ((paging-offset 2))
        (handler-bind
 	   ((newline (lambda (condition)
 		       (declare (ignore condition))
-		       (when (>= (incf *paging-offset*)
-				 muerte.x86-pc::*screen-height*)
-			 (format t "~&more? ")
-			 (loop
+		       (when (and paging-offset
+				  (>= (incf paging-offset)
+				      muerte.x86-pc::*screen-height*))
+			 (format t "~&more? (y/n/a) ")
+			 (prog ()
+			  loop
 			   (case (muerte.x86-pc.keyboard:poll-char)
-			     ((#\esc #\n #\N)
+			     ((#\esc)
+			      (break "Console pager"))
+			     ((#\n #\N)	; No more
 			      (return-from paging (values)))
-			     ((#\y #\Y #\space #\newline)
-			      (setf *paging-offset* 1)
-			      (return))))))))
+			     ((#\a #\A)	; Quit paging
+			      (setf paging-offset nil))
+			     ((#\newline #\x)
+			      (setf paging-offset
+				(1- muerte.x86-pc::*screen-height*)))
+			     ((#\y #\Y #\space) ; One more page
+			      (setf paging-offset 1))
+			     (t (go loop))))
+			 (write-char #\return)
+			 (clear-line *standard-output* 0 (cursor-y *standard-output*))
+			 ))))
 	 , at body))))
 
 (defun tp (x) (dotimes (i x) (print i)))




From ffjeld at common-lisp.net  Mon Jul 12 09:11:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 02:11:08 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bjwq4-0004q2-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed new-binding-location, which didn't do the right thing with the
default argument.

Date: Mon Jul 12 02:11:08 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.73 movitz/compiler.lisp:1.74
--- movitz/compiler.lisp:1.73	Sun Jul 11 15:58:56 2004
+++ movitz/compiler.lisp	Mon Jul 12 02:11:07 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.73 2004/07/11 22:58:56 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.74 2004/07/12 09:11:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2375,10 +2375,11 @@
 
 (defun new-binding-location (binding map &key (default nil default-p))
   (check-type binding (or binding (cons keyword binding)))
-  (cdr (or (assoc binding map)
-	   (if default-p
-	       default
-	     (error "No location for ~S." binding)))))
+  (let ((x (assoc binding map)))
+    (cond
+     (x (cdr x))
+     (default-p default)
+     (t (error "No location for ~S." binding)))))
 
 (defun make-binding-map () nil)
 




From ffjeld at common-lisp.net  Mon Jul 12 09:11:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 02:11:24 -0700
Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog 
Message-ID: <E1BjwqK-0005LM-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Mon Jul 12 02:11:24 2004
Author: ffjeld

Index: movitz/doc/ChangeLog
diff -u movitz/doc/ChangeLog:1.5 movitz/doc/ChangeLog:1.6
--- movitz/doc/ChangeLog:1.5	Wed Jul  7 17:16:36 2004
+++ movitz/doc/ChangeLog	Mon Jul 12 02:11:24 2004
@@ -1,3 +1,9 @@
+2004-07-12  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added top-level-command :more, that will evaluate a form while
+	paging the console output. That is, prompt for a key-press after
+	each screenful.
+
 2004-07-08  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Migration to the new basic-vector data-structure is completed




From ffjeld at common-lisp.net  Mon Jul 12 09:11:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 02:11:56 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/console.lisp 
Message-ID: <E1Bjwqq-00033w-00@common-lisp.net>

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

Modified Files:
	console.lisp 
Log Message:
Add newline signal to scroll-down.

Date: Mon Jul 12 02:11:56 2004
Author: ffjeld

Index: movitz/losp/lib/console.lisp
diff -u movitz/losp/lib/console.lisp:1.4 movitz/losp/lib/console.lisp:1.5
--- movitz/losp/lib/console.lisp:1.4	Mon Jan 19 03:23:44 2004
+++ movitz/losp/lib/console.lisp	Mon Jul 12 02:11:56 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 14 18:14:16 2003
 ;;;;                
-;;;; $Id: console.lisp,v 1.4 2004/01/19 11:23:44 ffjeld Exp $
+;;;; $Id: console.lisp,v 1.5 2004/07/12 09:11:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -213,6 +213,7 @@
       (setf (console-char console x y)
 	(console-char console x (1+ y)))))
   (clear-line console 0 (1- (console-height console)))
+  (signal 'muerte::newline)
   nil)
 
 (defmethod scroll-down :after (console)




From ffjeld at common-lisp.net  Mon Jul 12 09:12:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 02:12:40 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <E1BjwrY-0003ge-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv13858

Modified Files:
	textmode.lisp 
Log Message:
Tweaked when newline is signalled during scroll-down.

Date: Mon Jul 12 02:12:40 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.7 movitz/losp/x86-pc/textmode.lisp:1.8
--- movitz/losp/x86-pc/textmode.lisp:1.7	Mon Jul 12 00:57:52 2004
+++ movitz/losp/x86-pc/textmode.lisp	Mon Jul 12 02:12:40 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.7 2004/07/12 07:57:52 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.8 2004/07/12 09:12:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -69,13 +69,13 @@
 (defun textmode-write-char (c)
   (case c
     (#\newline
+     (setf *cursor-x* 0)
+     (move-vga-cursor 0 *cursor-y*)
      (cond
       ((>= (1+ *cursor-y*) *screen-height*)
        (textmode-scroll-down)
        (setf *cursor-y* (1- *screen-height*)))
-      (t (incf *cursor-y*)))
-     (setf *cursor-x* 0)
-     (move-vga-cursor 0 *cursor-y*))
+      (t (incf *cursor-y*))))
     (#\backspace
      (if (/= 0 *cursor-x*)
 	 (decf *cursor-x*)
@@ -125,13 +125,13 @@
 
 (defun textmode-scroll-down ()
   (declare (special muerte.lib::*scroll-offset*))
-  (signal 'newline)
   (incf muerte.lib::*scroll-offset*)
   (loop with stride = (* 2 *screen-stride*)
       for y below *screen-height*
       as src from (+ *screen* stride) by stride
       as dst from *screen* by stride
-      do (textmode-copy-line dst src *screen-width*)))
+      do (textmode-copy-line dst src *screen-width*))
+  (signal 'newline))
 
 (defun textmode-clear-line (from-column line)
   (let ((dest (+ *screen* (* line *screen-width* 2) (* from-column 2))))




From ffjeld at common-lisp.net  Mon Jul 12 09:13:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 02:13:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bjws4-0004kD-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved logandc1 on bignums.

Date: Mon Jul 12 02:13:12 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.43 movitz/losp/muerte/integers.lisp:1.44
--- movitz/losp/muerte/integers.lisp:1.43	Sun Jul 11 16:05:24 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 02:13:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.43 2004/07/11 23:05:24 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.44 2004/07/12 09:13:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -88,7 +88,7 @@
 		  finally (return (if (zerop constant-term)
 				      non-constant-operands
 				    (cons constant-term non-constant-operands))))))
-	 `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands))))))
+	 `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands))))))
 
 (defun + (&rest terms)
   (declare (without-check-stack-limit))
@@ -1553,15 +1553,44 @@
 	(reduce #'logand integers)))))
 
 (defun logandc1 (integer1 integer2)
-  (number-double-dispatch (integer1 integer2)
-    ((t positive-fixnum)
-     (with-inline-assembly (:returns :eax)
-       (:compile-form (:result-mode :eax) integer1)
-       (:call-global-constant unbox-u32)
-       (:shll #.movitz:+movitz-fixnum-shift+ :ecx)
-       (:compile-form (:result-mode :eax) integer2)
-       (:notl :ecx)
-       (:andl :ecx :eax)))))
+  (macrolet
+      ((do-it ()
+	 `(number-double-dispatch (integer1 integer2)
+	    ((t positive-fixnum)
+	     (with-inline-assembly (:returns :eax :type fixnum)
+	       (:compile-form (:result-mode :eax) integer1)
+	       (:call-global-constant unbox-u32)
+	       (:shll ,movitz:+movitz-fixnum-shift+ :ecx)
+	       (:compile-form (:result-mode :eax) integer2)
+	       (:notl :ecx)
+	       (:andl :ecx :eax)))
+	    (((eql 0) t) integer2)
+	    (((eql -1) t) 0)
+	    ((positive-fixnum positive-bignum)
+	     (%bignum-canonicalize
+	      (with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:eax :ecx) (copy-bignum integer2) integer1)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:notl :ecx)
+		(:andl :ecx
+		       (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))
+	    ((positive-bignum positive-bignum)
+	     (%bignum-canonicalize
+	      (with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:eax :ebx) (copy-bignum integer2) integer1)
+		(:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			 :ecx)
+		(:leal ((:ecx 4) -4) :edx)
+	       pb-pb-andc1-loop
+		(:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		       :ecx)
+		(:notl :ecx)
+		(:andl :ecx
+		       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		(:subl 4 :edx)
+		(:jnc 'pb-pb-andc1-loop)))))))
+    (do-it)))
+
 
 (defun logandc2 (integer1 integer2)
   (logandc1 integer2 integer1))




From ffjeld at common-lisp.net  Mon Jul 12 11:09:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:09:12 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BjygK-0005rm-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Changed the low-level formatting of bignums: Now the number of bigits
is stored as factors of 4. This restricts the number of bigits to
(1- (expt 2 14)), which is still plenty.

Date: Mon Jul 12 04:09:12 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.26 movitz/storage-types.lisp:1.27
--- movitz/storage-types.lisp:1.26	Thu Jul  8 05:01:51 2004
+++ movitz/storage-types.lisp	Mon Jul 12 04:09:12 2004
@@ -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.26 2004/07/08 12:01:51 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.27 2004/07/12 11:09:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1243,7 +1243,15 @@
    (length
     :binary-type lu16
     :initarg :length
-    :accessor movitz-bignum-length)
+    :accessor movitz-bignum-length
+    :map-binary-write (lambda (x &optional type)
+			(declare (ignore type))
+			(check-type x (unsigned-byte 14))
+			(* x 4))
+    :map-binary-read (lambda (x &optional type)
+		       (declare (ignore type))
+		       (assert (zerop (mod x 4)))
+		       (truncate x 4)))
    (bigit0 :binary-type :label)
    (value
     :initarg :value




From ffjeld at common-lisp.net  Mon Jul 12 11:09:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:09:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BjygQ-0005zR-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Changed the low-level formatting of bignums: Now the number of bigits
is stored as factors of 4. This restricts the number of bigits to
(1- (expt 2 14)), which is still plenty.

Date: Mon Jul 12 04:09:18 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.16 movitz/losp/muerte/inspect.lisp:1.17
--- movitz/losp/muerte/inspect.lisp:1.16	Thu Jul  8 14:48:58 2004
+++ movitz/losp/muerte/inspect.lisp	Mon Jul 12 04:09:18 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.16 2004/07/08 21:48:58 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.17 2004/07/12 11:09:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -284,11 +284,11 @@
 	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 	    (:shrl 16 :ecx)
 	   shrink-loop
-	    (:cmpl 1 :ecx)
+	    (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
 	    (:je 'shrink-no-more)
-	    (:cmpl 0 (:eax (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+	    (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
 	    (:jnz 'shrink-done)
-	    (:subl 1 :ecx)
+	    (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 	    (:jmp 'shrink-loop)
 	   shrink-no-more
 	    (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+)
@@ -299,6 +299,8 @@
 		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		   (:jmp 'done)))
 	   shrink-done
+	    (:testb 3 :cl)
+	    (:jnz '(:sub-program () (:int 59)))
 	    (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
 	   done
 	    )))




From ffjeld at common-lisp.net  Mon Jul 12 11:09:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:09:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BjygV-000625-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Changed the low-level formatting of bignums: Now the number of bigits
is stored as factors of 4. This restricts the number of bigits to
(1- (expt 2 14)), which is still plenty.

Date: Mon Jul 12 04:09:23 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.44 movitz/losp/muerte/integers.lisp:1.45
--- movitz/losp/muerte/integers.lisp:1.44	Mon Jul 12 02:13:12 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 04:09:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.44 2004/07/12 09:13:12 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.45 2004/07/12 11:09:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -137,7 +137,7 @@
 		   (:testl :ebx :ebx)
 		   (:jz 'pfix-pbig-done)
 		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		   (:cmpl 1 :ecx)
+		   (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
 		   (:jne 'not-size1)
 		   (:compile-form (:result-mode :ecx) x)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -154,12 +154,12 @@
 		   (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 				      'retry-jumper)
 				    (:edi (:edi-offset atomically-status))))
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 2 movitz:+movitz-fixnum-factor+))
+		   (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			  :eax)		; Number of words
 		   (:call-global-constant get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		   (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :edx)
 		   (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
 		  copy-bignum-loop
@@ -180,11 +180,11 @@
 		  add-bignum-done
 		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			    :ecx)
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :ecx)
 		   (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
 		   (:je 'no-expansion)
-		   (:addl #x10000 (:eax ,movitz:+other-type-offset+))
+		   (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
 		   (:call-global-constant cons-commit)
@@ -202,7 +202,7 @@
 							       pfix-pbig-done))
 		   (:compile-two-forms (:eax :ebx) y x)
 		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		   (:cmpl 1 :ecx)
+		   (:cmpl 4 :ecx)
 		   (:jne 'not-size1)
 		   (:compile-form (:result-mode :ecx) x)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -218,12 +218,12 @@
 		   (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 				      'retry-jumper)
 				    (:edi (:edi-offset atomically-status))))
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 1 movitz:+movitz-fixnum-factor+))
+		   (:leal ((:ecx 1) ,(* 1 movitz:+movitz-fixnum-factor+))
 			  :eax)		; Number of words
 		   (:call-global-constant get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		   (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :edx)
 		  copy-bignum-loop
 		   (:subl ,movitz:+movitz-fixnum-factor+ :edx)
@@ -244,11 +244,11 @@
 		  add-bignum-done
 		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			    :ecx)
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :ecx)		; result bignum word-size
 		   (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
 		   (:jne 'no-expansion)
-		   (:subl #x10000 (:eax ,movitz:+other-type-offset+))
+		   (:subl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
 		   (:call-global-constant cons-commit)
@@ -256,6 +256,63 @@
 				    (:edi (:edi-offset atomically-status))))
 		   
 		  pfix-pbig-done))
+		#+ignore
+		((positive-bignum positive-bignum)
+		 (if (< (%bignum-bigits y) (%bignum-bigits x))
+		     (+ y x)
+		   ;; Assume x is smallest.
+		   (with-inline-assembly (:returns :eax :labels (retry-copy
+								 copy-bignum-loop
+								 add-bignum-loop
+								 add-bignum-done
+								 no-expansion
+								 pfix-pbig-done))
+		    retry-copy
+		     (:compile-form (:result-mode :eax) y)
+		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:declare-label-set retry-jumper (retry-copy))
+		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
+		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
+					'retry-jumper)
+				      (:edi (:edi-offset atomically-status))))
+		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 2 movitz:+movitz-fixnum-factor+))
+			    :eax)	; Number of words
+		     (:call-global-constant get-cons-pointer)
+		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
+		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+			    :edx)
+		     (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
+		    copy-bignum-loop
+		     (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+		     (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
+		     (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
+		     (:jnz 'copy-bignum-loop)
+		     ;; We now have a copy of Y in EAX.
+		     (:load-lexical (:lexical-binding x) :ebx)
+
+		     (:xorl :ebx :ebx)
+		     (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:jnc 'add-bignum-done)
+		    add-bignum-loop
+		     (:addl 4 :ebx)
+		     (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:jc 'add-bignum-loop)
+		    add-bignum-done
+		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			      :ecx)
+		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+			    :ecx)
+		     (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:je 'no-expansion)
+		     (:addl #x10000 (:eax ,movitz:+other-type-offset+))
+		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+		    no-expansion
+		     (:call-global-constant cons-commit)
+		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+				      (:edi (:edi-offset atomically-status))))
+		   
+		    pfix-pbig-done)))
 		)))
 	(do-it)))
    (t (&rest terms)
@@ -409,8 +466,7 @@
 		    (:ret)))
 
 	    ;; Both n1 and n2 are positive bignums of the same size, namely ECX.
-	    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+))
-		   :edx)		; counter
+	    (:movl :ecx :edx)		; counter
 	   positive-compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'positive-compare-lsb)
@@ -436,8 +492,7 @@
 		    (:ret)))
 
 	    ;; Both n1 and n2 are negative bignums of the same size, namely ECX.
-	    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+))
-		   :edx)		; counter
+	    (:movl :ecx :edx)		; counter
 	   negative-compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'negative-compare-lsb)
@@ -476,8 +531,7 @@
 	    (:jne 'done)
 	    ;; Ok.. we have two bignums of identical sign and size.
 	    (:shrl 16 :ecx)
-	    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
-		   :edx)		; counter
+	    (:movl :ecx :edx)		; counter
 	   compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'done)
@@ -998,7 +1052,7 @@
 	       (:compile-form (:result-mode :ebx) integer)
 	       (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
 			:ecx)
-	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* -1 movitz:+movitz-fixnum-factor+))
+	       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
 		      :eax)		; bigits-1
 	       (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		      :ecx)
@@ -1069,7 +1123,8 @@
 		     (:store-lexical (:lexical-binding d1) :edx :type fixnum)
 		     (:compile-form (:result-mode :eax)
 				    (malloc-data-words 3))
-		     (:movl ,(dpb 2 (byte 16 16) (movitz:tag :bignum 0))
+		     (:movl ,(dpb (* 2 movitz:+movitz-fixnum-factor+)
+				  (byte 16 16) (movitz:tag :bignum 0))
 			    (:eax ,movitz:+other-type-offset+))
 		     (:load-lexical (:lexical-binding d0) :ecx)
 		     (:movl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
@@ -1128,8 +1183,7 @@
 		     (:compile-form (:result-mode :eax) y)
 		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			      :ecx)
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
-			     ,(* 2 movitz:+movitz-fixnum-factor+))
+		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			    :eax)
 		     (:call-global-constant get-cons-pointer) ; New bignum into EAX
 
@@ -1139,7 +1193,7 @@
 		     (:store-lexical (:lexical-binding r) :eax :type bignum)
 
 		     (:movl :eax :ebx)	; r into ebx
-		     (:xorl :ecx :ecx)
+		     (:xorl :ecx :ecx)	; counter
 		     (:xorl :edx :edx)	; initial carry
 		     (:std)		; Make EAX, EDX, ESI non-GC-roots.
 		     (:compile-form (:result-mode :esi) x)
@@ -1147,36 +1201,35 @@
 		     (:jns 'multiply-loop)
 		     (:negl :esi)	; can't overflow
 		    multiply-loop
-		     (:movl :edx (:ebx (:ecx 4) ; new
+		     (:movl :edx (:ebx (:ecx 1) ; new
 				       ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 		     (:compile-form (:result-mode :ebx) y)
-		     (:movl (:ebx (:ecx 4) ; old
+		     (:movl (:ebx (:ecx 1) ; old
 				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 			    :eax)
 		     
 		     (:mull :esi :eax :edx)
 		     (:compile-form (:result-mode :ebx) r)
 		     (:addl :eax
-			    (:ebx (:ecx 4)
+			    (:ebx (:ecx 1)
 				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 		     (:adcl 0 :edx)
-		     (:addl 1 :ecx)
+		     (:addl 4 :ecx)
 		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:ja 'multiply-loop)
 		     (:testl :edx :edx)
 		     (:jz 'no-carry-expansion)
 		     (:movl :edx
-			    (:ebx (:ecx 4)
+			    (:ebx (:ecx 1)
 				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-		     (:addl 1 :ecx)
+		     (:addl 4 :ecx)
 		     (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		    no-carry-expansion
 		     (:movl (:ebp -4) :esi)
 		     (:movl :ebx :eax)
 		     (:movl :edi :edx)
 		     (:cld)		; EAX, EDX, and ESI are GC roots again.
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
-			     ,movitz:+movitz-fixnum-factor+)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
 		     (:call-global-constant cons-commit)
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
@@ -1262,7 +1315,8 @@
 		`(let (r n)
 		   (with-inline-assembly (:returns :multiple-values)
 		     (:compile-form (:result-mode :ebx) number)
-		     (:cmpw 1 (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw ,movitz:+movitz-fixnum-factor+
+			    (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:jne 'not-size1)
 		     (:compile-form (:result-mode :ecx) divisor)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -1289,7 +1343,7 @@
 					'retry-jumper)
 				      (:edi (:edi-offset atomically-status))))
 
-		     (:leal ((:ecx 4) 4) :eax) ; Number of words
+		     (:leal ((:ecx 1) 4) :eax) ; Number of words
 		     (:call-global-constant get-cons-pointer) ; New bignum into EAX
 		     
 
@@ -1308,13 +1362,13 @@
 		    divide-loop
 		     (:load-lexical (:lexical-binding number) :ebx)
 		     (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
-				  -4 (:ecx 4))
+				  -4 (:ecx 1))
 			    :eax)
 		     (:divl :esi :eax :edx)
 		     (:load-lexical (:lexical-binding r) :ebx)
 		     (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
-				       -4 (:ecx 4)))
-		     (:subl 1 :ecx)
+				       -4 (:ecx 1)))
+		     (:subl 4 :ecx)
 		     (:jnz 'divide-loop)
 		     (:movl :edi :eax)	; safe value
 		     (:leal ((:edx ,movitz:+movitz-fixnum-factor+)) :edx)
@@ -1323,14 +1377,14 @@
 		     (:movl :ebx :eax)
 		     (:movl :edx :ebx)
 
-		     (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			      :ecx)
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) #.movitz:+movitz-fixnum-factor+)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
 		     (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
 		     (:jne 'no-more-shrinkage)
 		     
-		     (:subw 1 (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:subw 4 (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		     (:cmpl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx)
 		     (:jne 'no-more-shrinkage)
@@ -1536,7 +1590,7 @@
 		      (:compile-two-forms (:eax :ebx) (copy-bignum x) y)
 		      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			       :ecx)
-		      (:leal ((:ecx 4) -4) :edx)
+		      (:leal ((:ecx 1) -4) :edx)
 		     pb-pb-and-loop
 		      (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 			     :ecx)
@@ -1580,7 +1634,7 @@
 		(:compile-two-forms (:eax :ebx) (copy-bignum integer2) integer1)
 		(:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			 :ecx)
-		(:leal ((:ecx 4) -4) :edx)
+		(:leal ((:ecx 1) -4) :edx)
 	       pb-pb-andc1-loop
 		(:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 		       :ecx)
@@ -1632,8 +1686,7 @@
 		       (:compile-two-forms (:eax :ebx) r y)
 		       (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 				:ecx)
-		       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
-			       ,(* -1 movitz:+movitz-fixnum-factor+))
+		       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
 			      :edx)	; EDX is loop counter
 		      or-loop
 		       (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
@@ -1707,8 +1760,7 @@
 			(:compile-two-forms (:eax :ebx) r y)
 			(:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 				 :ecx)
-			(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
-				,(* -1 movitz:+movitz-fixnum-factor+))
+			(:leal ((:ecx 1),(* -1 movitz:+movitz-fixnum-factor+))
 			       :edx)	; EDX is loop counter
 		       xor-loop
 			(:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
@@ -1717,9 +1769,7 @@
 			       (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 			(:subl 4 :edx)
 			(:jnc 'xor-loop)
-		       
-			(:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-				 :ecx)))))
+			))))
 	       (do-it)))))))
    (t (&rest integers)
       (declare (dynamic-extent integers))
@@ -1793,8 +1843,8 @@
 	       (:xorl :ecx :ecx)	; counter
 	      fill-ones-loop
 	       (:movl #xffffffff
-		      (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-	       (:addl 1 :ecx)
+		      (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	       (:addl 4 :ecx)
 	       (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
 	       (:jne 'fill-ones-loop)
 	       
@@ -1816,7 +1866,7 @@
 	       (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
 			:ecx)
 	       (:andl :edx		; And EDX with the MSB bigit.
-		      (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+		      (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
 	       (:movl :edi :edx)
 	       (:movl :edi :eax)
 	       (:cld)			; =================> CLD
@@ -1843,9 +1893,10 @@
 		 (:compile-form (:result-mode :ebx) integer)
 		 (:compile-form (:result-mode :eax) position)
 		 (:movl :eax :ecx)	; compute bigit-number in ecx
-		 (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx)
-		 (:addl 1 :ecx)
-		 (:cmpl #x10000 :ecx)
+		 (:sarl 5 :ecx)
+		 (:andl -4 :ecx)
+		 (:addl 4 :ecx)
+		 (:cmpl #x4000 :ecx)
 		 (:jae 'position-outside-integer)
 		 (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		 (:jc '(:sub-program (position-outside-integer)
@@ -1853,11 +1904,11 @@
 			(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 			(:jmp 'done-u32)))
 		 (:std)
-		 (:movl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		 (:movl (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 			:eax)
 		 (:movl 0 :edx)		; If position was in last bigit.. (don't touch EFLAGS)
 		 (:je 'no-top-bigit)	; ..we must zero-extend rather than read top bigit.
-		 (:movl (:ebx (:ecx 4) ,(+ 0 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		 (:movl (:ebx (:ecx 1) ,(+ 0 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 			:edx)		; Read top bigit into EDX
 		no-top-bigit
 		 (:testl #xff00 (:ebx ,movitz:+other-type-offset+))
@@ -1885,7 +1936,8 @@
 		 (:movl :edi :edx)
 		 (:cld)
 		 ;; See if we can return same bignum..
-		 (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+		 (:cmpl ,(dpb movitz:+movitz-fixnum-factor+
+			      (byte 16 16) (movitz:tag :bignum 0))
 			(:ebx ,movitz:+other-type-offset+))			     
 		 (:jne 'cant-return-same)
 		 (:cmpl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
@@ -1903,8 +1955,8 @@
 		   (with-inline-assembly (:returns :eax)
 		     (:compile-form (:result-mode :ebx) integer)
 		     (:compile-form (:result-mode :ecx) position)
-		     (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx
-		     (:cmpl #x10000 :ecx)
+		     (:shrl 5 :ecx) ; compute fixnum bigit-number in ecx
+		     (:cmpl #x4000 :ecx)
 		     (:jnc 'position-outside-integer)
 		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:jbe '(:sub-program (position-outside-integer)
@@ -1916,8 +1968,8 @@
 		     (:movl :ecx :eax)	; keep size/fixnum in EAX.
 		     (:addl :edx :ecx)
 		     (:into)		; just to make sure
-		     (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute msb bigit index in ecx
-		     (:addl 1 :ecx)
+		     (:shrl 5 :ecx)	; compute msb bigit index/fixnum in ecx
+		     (:addl 4 :ecx)
 		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (je '(:sub-program (equal-size-maybe-return-same)
 			   (:testl :edx :edx) ; Can only return same if (zerop position).
@@ -1932,7 +1984,7 @@
 			   (:shll :cl :edx)
 			   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			    :ecx)
-			   (:cmpl :edx (:ebx (:ecx 4)
+			   (:cmpl :edx (:ebx (:ecx 1)
 					,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
 			   (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size.
 			   (:cld)	; =================>
@@ -1952,7 +2004,7 @@
 		     ;; size smaller before proceeding. new-size = (- source-int-length position)
 		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			      :ecx)	; length of source-integer
-		     (:shll ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; fixnum bit-position
+		     (:shll 5 :ecx)	; fixnum bit-position
 		     (:xorl :eax :eax)	; In case the new size is zero.
 		     (:subl :edx :ecx)	; subtract position
 		     (:js '(:sub-program (should-not-happen)
@@ -1981,7 +2033,7 @@
 		     ;; (:store-lexical (:lexical-binding r) :eax :type t)
 		     (:popl :ecx)
 		     (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header.
-		     (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ecx)
+		     (:shll 16 :ecx)
 		     (:orl ,(movitz:tag :bignum 0) :ecx)
 		     (:movl :ecx (:eax ,movitz:+other-type-offset+))
 		     (:compile-form (:result-mode :ebx) integer)
@@ -1995,13 +2047,13 @@
 			      :ecx)	; length of source-integer
 		     ;; Initialize tail-tmp to #xffffffff, meaning copy from source-integer.
 		     (:movl #xffffffff
-			    (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			    (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		     (:cmpw :cx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:jc '(:sub-program (result-too-big-shouldnt-happen)
 			    (:break)))
 		     (:jne 'tail-tmp-ok)
 		     ;; Sizes was equal, so set tail-tmp to zero.
-		     (:movl 0 (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:movl 0 (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		    tail-tmp-ok
 		     ;; Now copy the relevant part of the integer
 		     (:std)
@@ -2014,14 +2066,14 @@
 		    copy-integer
 		     (:movl (:eax) :edx)
 		     (:addl 4 :eax)
-		     (:movl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     (:addl 1 :ecx)
+		     (:movl :edx (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:addl 4 :ecx)
 		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:jne 'copy-integer)
 		     ;; Copy one more than the length, namely the tmp at the end.
 		     ;; Tail-tmp was initialized to a bit-mask above.
 		     (:movl (:eax) :edx)
-		     (:andl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:andl :edx (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		     ;; Copy done, now shift
 		     (:compile-form (:result-mode :ecx) position)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -2029,11 +2081,11 @@
 		     (:jz 'shift-done)	; if (zerop (mod position 32)), no shift needed.
 		     (:xorl :edx :edx)	; counter
 		    shift-loop
-		     (:movl (:ebx (:edx 4) ,(+ 4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:movl (:ebx (:edx 1) ,(+ 4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 			    :eax)	; Next bigit into eax
 		     (:shrdl :cl :eax	; Now shift bigit, with msbs from eax.
-			     (:ebx (:edx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     (:addl 1 :edx)
+			     (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:addl 4 :edx)
 		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:jne 'shift-loop)
 		    shift-done
@@ -2048,25 +2100,25 @@
 		     (:shll :cl :eax)
 		     (:subl 1 :eax)
 		     (:andl :eax
-			    (:ebx (:edx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+			    (:ebx (:edx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
 		    mask-done
-		     (:movl :edi :edx)	; safe EDX
+		     ;; (:movl :edi :edx)	; safe EDX
 		     (:movl :edi :eax)	; safe EAX
 		     (:cld)
 		     ;; Now we must zero-truncate the result bignum in EBX.
 		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			      :ecx)
 		    zero-truncate-loop
-		     (:cmpl 0 (:ebx (:ecx 4)
+		     (:cmpl 0 (:ebx (:ecx 1)
 				    ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
 		     (:jne 'zero-truncate-done)
-		     (:subl 1 :ecx)
+		     (:subl 4 :ecx)
 		     (:jnz 'zero-truncate-loop)
 		     ;; Zero bigits means the entire result collapsed to zero.
 		     (:xorl :eax :eax)
 		     (:jmp 'return-fixnum) ; don't commit the bignum allocation.
 		    zero-truncate-done
-		     (:cmpl 1 :ecx)	; If result size is 1, the result might have..
+		     (:cmpl 4 :ecx)	; If result size is 1, the result might have..
 		     (:jne 'complete-bignum-allocation) ; ..collapsed to a fixnum.
 		     (:cmpl ,movitz:+movitz-most-positive-fixnum+
 			    (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
@@ -2078,7 +2130,7 @@
 		    complete-bignum-allocation
 		     (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 		     (:movl :ebx :eax)
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
 		     (:call-global-constant cons-commit)
 		    return-fixnum
@@ -2126,14 +2178,14 @@
 		 `((:leal (:eax ,(- (movitz:tag :other))) :ecx)
 		   (:testb 7 :cl)
 		   (:jnz 'nix)
-		   (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+		   (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0))
 			  (:eax ,movitz:+other-type-offset+))
 		   (:je 'done)))
 		((and (= 0 position) (<= (- 32 movitz:+movitz-fixnum-shift+) size ))
 		 `((:leal (:eax ,(- (movitz:tag :other))) :ecx)
 		   (:testb 7 :cl)
 		   (:jnz 'nix)
-		   (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+		   (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0))
 			  (:eax ,movitz:+other-type-offset+))
 		   (:jne 'nix)
 		   (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))




From ffjeld at common-lisp.net  Mon Jul 12 11:09:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:09:29 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1Bjygb-0006Ao-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Changed the low-level formatting of bignums: Now the number of bigits
is stored as factors of 4. This restricts the number of bigits to
(1- (expt 2 14)), which is still plenty.

Date: Mon Jul 12 04:09:29 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.11 movitz/losp/muerte/more-macros.lisp:1.12
--- movitz/losp/muerte/more-macros.lisp:1.11	Thu Jun 10 12:27:36 2004
+++ movitz/losp/muerte/more-macros.lisp	Mon Jul 12 04:09:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.11 2004/06/10 19:27:36 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.12 2004/07/12 11:09:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -309,12 +309,10 @@
 
 
 (define-compiler-macro %bignum-bigits (x)
-  `(with-inline-assembly (:returns :eax)
+  `(with-inline-assembly (:returns :eax :type (unsigned-byte 14))
      (:compile-form (:result-mode :eax) ,x)
      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-	      :ecx)
-     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+))
-	    :eax)))
+	      :eax)))
 
 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 




From ffjeld at common-lisp.net  Mon Jul 12 11:09:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:09:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1Bjygg-0006Er-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Changed the low-level formatting of bignums: Now the number of bigits
is stored as factors of 4. This restricts the number of bigits to
(1- (expt 2 14)), which is still plenty.

Date: Mon Jul 12 04:09:34 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.14 movitz/losp/muerte/scavenge.lisp:1.15
--- movitz/losp/muerte/scavenge.lisp:1.14	Mon Jul 12 00:56:45 2004
+++ movitz/losp/muerte/scavenge.lisp	Mon Jul 12 04:09:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.14 2004/07/12 07:56:45 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.15 2004/07/12 11:09:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,12 +44,12 @@
 		 `(with-inline-assembly (:returns :boolean-zf=1)
 		    (:compile-form (:result-mode :eax) ,x)
 		    (:cmpw ,code :ax))))
-	     (word-upper16 (x)
-	       "Consider x as a 32-bit integer, and return the upper 16 bits (as a fixnum)."
+	     (word-bigits (x)
+	       "If x is a bignum header word, return the number of bigits."
 	       `(with-inline-assembly (:returns :eax)
 		  (:compile-form (:result-mode :eax) ,x)
-		  (:andl #xffff0000 :eax)
-		  (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax))))
+		  (:andl #xfffc0000 :eax)
+		  (:shrl 16 :eax))))
     (do ((*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
@@ -65,7 +65,7 @@
 	  (assert (evenp scan) ()
 	    "Scanned #x~Z at odd address #x~X." x scan)
 	  ;; Just skip the bigits
-	  (let* ((bigits (word-upper16 x))
+	  (let* ((bigits (word-bigits x))
 		 (delta (1+ (logand bigits -2))))
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan delta)))




From ffjeld at common-lisp.net  Mon Jul 12 11:10:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:10:40 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1Bjyhk-0000UE-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv1865

Modified Files:
	debugger.lisp 
Log Message:
Slight fix to *call-site-patterns*, so that the arglist to recursive
calls might be recognized.

Date: Mon Jul 12 04:10:40 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.14 movitz/losp/x86-pc/debugger.lisp:1.15
--- movitz/losp/x86-pc/debugger.lisp:1.14	Sun Jul 11 12:26:11 2004
+++ movitz/losp/x86-pc/debugger.lisp	Mon Jul 12 04:10:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.14 2004/07/11 19:26:11 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.15 2004/07/12 11:10:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -220,10 +220,10 @@
 			    (#x8b #x5e (:ebx :esi)) ; (:movl (:esi x) :ebx)
 			    (#x33 #xdb (:constant :ebx 0))
 			    )))
-		(:or ((:or (#x8b #x56 (:edx :esi)) ;     (:movl (:esi x) :edx)
-			   (#x8b #x54 #x37 (:edx :esi+edi))) ;#<asm MOVL [#x39+%EDI+%ESI] => %EDX>
-		      #x8b #x72 #xfd)	;     (:movl (:edx -3) :esi)
-		     (#x8b #x74 #x7e (:any-offset))) ; #<asm MOVL [#x28+%ESI+%EDI*2] => %ESI>
+		(:* 1 ((:or ((:or (#x8b #x56 (:edx :esi)) ;     (:movl (:esi x) :edx)
+				  (#x8b #x54 #x37 (:edx :esi+edi))) ;#<asm MOVL [#x39+%EDI+%ESI] => %EDX>
+			     #x8b #x72 #xfd) ;     (:movl (:edx -3) :esi)
+			    (#x8b #x74 #x7e (:any-offset))))) ; #<asm MOVL [#x28+%ESI+%EDI*2] => %ESI>
 		(:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl)
 		(:* 1 ((:or (#x8b #x55 (:edx :ebp))
 			    (#x8b #x56 (:edx :esi)))))




From ffjeld at common-lisp.net  Mon Jul 12 11:11:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 04:11:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BjyiK-0003Jf-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
This fix is about the new bignum formatting again.

Date: Mon Jul 12 04:11:16 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.22 movitz/losp/los0-gc.lisp:1.23
--- movitz/losp/los0-gc.lisp:1.22	Mon Jul 12 00:59:04 2004
+++ movitz/losp/los0-gc.lisp	Mon Jul 12 04:11:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.22 2004/07/12 07:59:04 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.23 2004/07/12 11:11:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -169,7 +169,8 @@
 			       (:edi (:edi-offset atomically-status))))
 		    (:int 113)		; This interrupt can be retried.
 		    (:jmp 'retry-cons)))
-	    (:movl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+	    (:movl ,(dpb movitz:+movitz-fixnum-factor+
+			 (byte 16 16) (movitz:tag :bignum 0))
 		   (:edx :eax 2))
 	    (:movl :ecx (:edx :eax 6))
 	    (:addl 8 :eax)




From ffjeld at common-lisp.net  Mon Jul 12 13:43:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 06:43:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bk15r-0008SQ-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
More bignum tweaks.

Date: Mon Jul 12 06:43:43 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.45 movitz/losp/muerte/integers.lisp:1.46
--- movitz/losp/muerte/integers.lisp:1.45	Mon Jul 12 04:09:23 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 06:43:43 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.45 2004/07/12 11:09:23 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.46 2004/07/12 13:43:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -192,6 +192,8 @@
 				    (:edi (:edi-offset atomically-status))))
 		   
 		  pfix-pbig-done))
+		((positive-bignum negative-fixnum)
+		 (+ y x))
 		((negative-fixnum positive-bignum)
 		 (with-inline-assembly (:returns :eax :labels (retry-not-size1
 							       not-size1
@@ -256,31 +258,44 @@
 				    (:edi (:edi-offset atomically-status))))
 		   
 		  pfix-pbig-done))
-		#+ignore
 		((positive-bignum positive-bignum)
 		 (if (< (%bignum-bigits y) (%bignum-bigits x))
 		     (+ y x)
 		   ;; Assume x is smallest.
-		   (with-inline-assembly (:returns :eax :labels (retry-copy
+		   (with-inline-assembly (:returns :eax :labels (retry-not-size1
+								 not-size1
+								 term-zero
 								 copy-bignum-loop
 								 add-bignum-loop
 								 add-bignum-done
 								 no-expansion
 								 pfix-pbig-done))
-		    retry-copy
+		     (:compile-two-forms (:eax :ebx) y x)
+		     (:testl :ebx :ebx)
+		     (:jz 'pfix-pbig-done)
+		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
+		     (:jne 'not-size1)
+		     (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		     (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		     (:jc 'retry-not-size1)
+		     (:call-global-constant box-u32-ecx)
+		     (:jmp 'pfix-pbig-done)
+		    retry-not-size1
 		     (:compile-form (:result-mode :eax) y)
 		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		     (:declare-label-set retry-jumper (retry-copy))
+		    not-size1
+		     (:declare-label-set retry-jumper (retry-not-size1))
 		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
 		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 					'retry-jumper)
 				      (:edi (:edi-offset atomically-status))))
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 2 movitz:+movitz-fixnum-factor+))
+		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			    :eax)	; Number of words
 		     (:call-global-constant get-cons-pointer)
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :edx)
 		     (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
 		    copy-bignum-loop
@@ -288,31 +303,46 @@
 		     (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
 		     (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
 		     (:jnz 'copy-bignum-loop)
-		     ;; We now have a copy of Y in EAX.
-		     (:load-lexical (:lexical-binding x) :ebx)
 
-		     (:xorl :ebx :ebx)
-		     (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-		     (:jnc 'add-bignum-done)
+		     (:load-lexical (:lexical-binding x) :ebx)
+		     (:xorl :edx :edx)	; counter
+		     (:xorl :ecx :ecx)	; Carry
 		    add-bignum-loop
-		     (:addl 4 :ebx)
-		     (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-		     (:jc 'add-bignum-loop)
+		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:jbe '(:sub-program (zero-padding-loop)
+			     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum
+						      'movitz::bigit0)))
+			     (:sbbl :ecx :ecx)
+			     (:negl :ecx) ; ECX = Add's Carry.
+			     (:addl 4 :edx)
+			     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			     (:jae 'zero-padding-loop)
+			     (:jmp 'add-bignum-done)))
+		     (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			    :ecx)
+		    term-zero
+		     (:adcl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:sbbl :ecx :ecx)
+		     (:negl :ecx)	; ECX = Add's Carry.
+		     (:addl 4 :edx)
+		     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:jae 'add-bignum-loop)
 		    add-bignum-done
 		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
 			      :ecx)
-		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
 		     (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
 		     (:je 'no-expansion)
-		     (:addl #x10000 (:eax ,movitz:+other-type-offset+))
+		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 		    no-expansion
 		     (:call-global-constant cons-commit)
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))
 		   
-		    pfix-pbig-done)))
+		    pfix-pbig-done)
+		   ))
 		)))
 	(do-it)))
    (t (&rest terms)
@@ -1251,43 +1281,6 @@
 
 ;;; Division
 
-(define-compiler-macro truncate (&whole form number &optional (divisor 1))
-  `(do-result-mode-case ()
-     (:plural
-      (no-macro-call , at form))
-     (t (truncate%1ret ,number ,divisor))))
-
-(defun truncate%1ret (number divisor)
-  (with-inline-assembly (:returns :multiple-values)
-    (:compile-form (:result-mode :eax) number)
-    (:compile-form (:result-mode :ebx) divisor)
-    (:movl :eax :ecx)
-    (:orl :ebx :ecx)
-    (:testb #.movitz::+movitz-fixnum-zmask+ :cl)
-    (:jnz '(:sub-program (not-integer) (:int 107)))
-    (:cdq :eax :edx)
-    (:idivl :ebx :eax :edx)
-    (:shll #.movitz::+movitz-fixnum-shift+ :eax)
-    (:clc)))
-
-(define-compiler-macro truncate%1ret (&whole form &environment env number divisor)
-  (cond
-   ((movitz:movitz-constantp divisor env)
-    (let ((d (movitz:movitz-eval divisor env)))
-      (check-type d number)
-      (case d
-	(0 (error "Truncate by zero."))
-	(1 number)
-	(t `(with-inline-assembly (:returns :eax :type fixnum)
-	      (:compile-form (:result-mode :eax) ,number)
-	      (:compile-form (:result-mode :ebx) ,divisor)
-	      (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-	      (:jnz '(:sub-program () (:int 66)))
-	      (:cdq :eax :edx)
-	      (:idivl :ebx :eax :edx)
-	      (:shll #.movitz::+movitz-fixnum-shift+ :eax))))))
-   (t form)))
-
 (defun truncate (number &optional (divisor 1))
   (numargs-case
    (1 (number)
@@ -1404,6 +1397,11 @@
 		     (:movl 2 :ecx)
 		     (:stc)))))
 	   (do-it)))
+	((positive-bignum positive-bignum)
+	 (cond
+	  ((= number divisor) (values 1 0))
+	  ((< number divisor) (values 0 number))
+	  (t (error "Don't know how to divide ~S with ~S." number divisor))))
 	))))
 
 (defun / (number &rest denominators)
@@ -1500,27 +1498,33 @@
   (rem bytespec #x400))
 
 (defun logbitp (index integer)
-  (check-type integer fixnum)
-  (with-inline-assembly (:returns :boolean-cf=1)
-    (:compile-two-forms (:eax :ebx) index integer)
-    (:testl #x80000003 :eax)
-    (:jnz '(:sub-program ()
-	    (:int 66)))
-    (:movl :eax :ecx)
-    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-    (:addl #.movitz::+movitz-fixnum-shift+ :ecx)
-    (:btl :ecx :ebx)))
+  (check-type index positive-fixnum)
+  (macrolet
+      ((do-it ()
+	 `(etypecase integer
+	    (fixnum
+	     (with-inline-assembly (:returns :boolean-cf=1)
+	       (:compile-two-forms (:ecx :ebx) index integer)
+	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
+	       (:addl ,movitz::+movitz-fixnum-shift+ :ecx)
+	       (:btl :ecx :ebx)))
+	    (positive-bignum
+	     (with-inline-assembly (:returns :boolean-cf=1)
+	       (:compile-two-forms (:ecx :ebx) index integer)
+	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
+	       (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))))
+    (do-it)))
 
-(define-compiler-macro logbitp (&whole form index integer &environment env)
-  (if (not (movitz:movitz-constantp index env))
-      form
-    (let ((index (movitz::movitz-eval index env)))
-      (check-type index (integer 0 30))
-      `(with-inline-assembly (:returns :boolean-cf=1)
-	 (:compile-form (:result-mode :eax) ,integer)
-	 (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-	 (:jnz '(:sub-program () (:int 107)))
-	 (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax)))))
+;;;(define-compiler-macro logbitp (&whole form index integer &environment env)
+;;;  (if (not (movitz:movitz-constantp index env))
+;;;      form
+;;;    (let ((index (movitz::movitz-eval index env)))
+;;;      (check-type index (integer 0 30))
+;;;      `(with-inline-assembly (:returns :boolean-cf=1)
+;;;	 (:compile-form (:result-mode :eax) ,integer)
+;;;	 (:testb #.movitz::+movitz-fixnum-zmask+ :al)
+;;;	 (:jnz '(:sub-program () (:int 107)))
+;;;	 (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax)))))
 
       
 ;;;(defun logand%2op (x y)




From ffjeld at common-lisp.net  Mon Jul 12 14:17:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 07:17:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bk1cJ-0005Jo-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added a slow but working implementation of bignum multiplication.

Date: Mon Jul 12 07:17:15 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.46 movitz/losp/muerte/integers.lisp:1.47
--- movitz/losp/muerte/integers.lisp:1.46	Mon Jul 12 06:43:43 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 07:17:14 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.46 2004/07/12 13:43:43 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.47 2004/07/12 14:17:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1114,12 +1114,7 @@
 	       (0 `(progn ,factor2 0))
 	       (1 factor2)
 	       (2 `(ash ,factor2 1))
-	       (t `(with-inline-assembly (:returns :eax :type integer)
-		     (:compile-form (:result-mode :eax) ,factor2)
-		     (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-		     (:jnz '(:sub-program () (:int 107)))
-		     (:imull ,f1 :eax :eax)
-		     (:into))))))
+	       (t `(no-macro-call * ,factor1 ,factor2)))))
 	  (t `(no-macro-call * ,factor1 ,factor2)))))
     (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))
 
@@ -1271,6 +1266,12 @@
 		     (:xorl #xff00 (:eax ,movitz:+other-type-offset+))
 		    positive-result
 		     )))
+		((positive-bignum positive-bignum)
+		 (do ((f y)
+		      (r 0))
+		     ((typep f 'fixnum) (+ r (* f x)))
+		   (setf r (+ r (* most-positive-fixnum x)))
+		   (setf f (- f most-positive-fixnum))))
 		)))
 	(do-it)))
    (t (&rest factors)




From ffjeld at common-lisp.net  Tue Jul 13 02:21:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:21:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BkCuq-0006Wf-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Fixed nasty bug in copy-bignum, which would cause GC corruption.

Date: Mon Jul 12 19:21:08 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.17 movitz/losp/muerte/inspect.lisp:1.18
--- movitz/losp/muerte/inspect.lisp:1.17	Mon Jul 12 04:09:18 2004
+++ movitz/losp/muerte/inspect.lisp	Mon Jul 12 19:21:08 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.17 2004/07/12 11:09:18 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.18 2004/07/13 02:21:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -199,10 +199,16 @@
 	     (:compile-form (:result-mode :ebx) clumps)
 	     (:shll 1 :ebx)
 	     (:globally (:call (:edi (:edi-offset malloc))))
-	     (:addl #.(movitz::tag :other) :eax))))
-    (dotimes (i clumps)
-      (setf (memref x -6 (* i 2) :lisp) nil
-	    (memref x -2 (* i 2) :lisp) nil))
+	     (:addl #.(movitz::tag :other) :eax)
+	     (:xorl :ecx :ecx)
+	    reset-loop
+	     (:movl :edi (:eax :ecx -6))
+	     (:addl 4 :ecx)
+	     (:cmpl :ecx :ebx)
+	     (:jae 'reset-loop))))
+    #+ignore
+    (dotimes (i (* 2 clumps))
+      (setf (memref x -6 i :lisp) nil))
     x))
 
 (defun malloc-data-clumps (clumps)
@@ -308,16 +314,16 @@
 
 (defun copy-bignum (old)
   (check-type old bignum)
-  (let* ((length (1+ (%bignum-bigits old)))
+  (let* ((length (%bignum-bigits old))
 	 (new (malloc-data-words length)))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
       (:compile-form (:result-mode :edx) length)
      copy-bignum-loop
-      (:subl #.movitz:+movitz-fixnum-factor+ :edx)
       (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx)
       (:movl :ecx (:eax :edx #.movitz:+other-type-offset+))
-      (:jnz 'copy-bignum-loop))))
+      (:subl #.movitz:+movitz-fixnum-factor+ :edx)
+      (:jnc 'copy-bignum-loop))))
 
 (defun print-bignum (x)
   (check-type x bignum)




From ffjeld at common-lisp.net  Tue Jul 13 02:24:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:24:36 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BkCyC-0006M0-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Re-arranged the run-time-context structure somewhat so as to keep
non-pointer slots in one place, and mark the out as such.

Date: Mon Jul 12 19:24:36 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.44 movitz/image.lisp:1.45
--- movitz/image.lisp:1.44	Fri Jul  9 09:12:10 2004
+++ movitz/image.lisp	Mon Jul 12 19:24:36 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.44 2004/07/09 16:12:10 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.45 2004/07/13 02:24:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -296,7 +296,7 @@
     :map-binary-read-delayed 'movitz-word
     :map-binary-write 'movitz-intern)
    (num-values
-    :binary-type lu32
+    :binary-type word			; Fixnum
     :initform 0)
    (values
     :binary-type #.(* 4 +movitz-multiple-values-limit+))
@@ -393,6 +393,14 @@
     :initform nil
     :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word)
+   (protect-non-pointer-area
+    :binary-type lu32
+    :initform 3)
+   (protect-non-pointer-count
+    :binary-type lu32
+    :initform (* 4 (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end)
+		      (bt:slot-offset 'movitz-constant-block 'non-pointers-start))))
+   (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START =======
    ;; (align-segment-descriptors :binary-type 4)
    (segment-descriptor-table :binary-type :label)
    (segment-descriptor-0
@@ -430,6 +438,15 @@
    (segment-descriptor-7
     :binary-type segment-descriptor
     :initform (make-segment-descriptor))
+   (bochs-flags
+    :binary-type lu32
+    :initform 0)
+   (scratch0				; A non-GC-root scratch register
+    :binary-type lu32
+    :initform 0)
+
+   (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END =======
+   
    (atomically-status
     :binary-type (define-bitfield atomically-status (lu32)
 		   (((:enum :byte (3 2))
@@ -455,13 +472,7 @@
     :initform nil
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
-    :binary-tag :primitive-function)
-   (bochs-flags
-    :binary-type lu32
-    :initform 0)
-   (scratch0				; A non-GC-root scratch register
-    :binary-type lu32
-    :initform 0))
+    :binary-tag :primitive-function))
   (:slot-align null-cons -1))
 
 (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)




From ffjeld at common-lisp.net  Tue Jul 13 02:26:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:26:14 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BkCzm-00020q-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Changed the run-time-context slot num-values from being lu32 to being
a word (i.e. a fixnum).

Date: Mon Jul 12 19:26:14 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.25 movitz/special-operators.lisp:1.26
--- movitz/special-operators.lisp:1.25	Sat Jul 10 06:29:18 2004
+++ movitz/special-operators.lisp	Mon Jul 12 19:26:14 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.25 2004/07/10 13:29:18 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.26 2004/07/13 02:26:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -906,7 +906,8 @@
 								   (* 4 i))))))
 				cloaked-code
 				(when (<= 3 num-values)
-				  `((:locally (:movl ,(- num-values 2)
+				  `((:locally (:movl ,(* +movitz-fixnum-factor+
+							 (- num-values 2))
 						     (:edi (:edi-offset num-values))))))
 				(loop for i downfrom (- num-values 2 1) to 0
 				    collect
@@ -1224,9 +1225,10 @@
 			       (loop for i from (- (length sub-forms) 3) downto 0
 				   collecting
 				     `(:locally (:popl (:edi (:edi-offset values ,(* i 4))))))
-			       (make-immediate-move (- (length sub-forms) 2) :ecx)
-			       `((:locally (:movl :ecx (:edi (:edi-offset num-values))))
-				 (:addl 2 :ecx)
+			       (make-immediate-move (length sub-forms) :ecx)
+			       `((:leal ((:ecx ,+movitz-fixnum-factor+) ,(* -2 +movitz-fixnum-factor+))
+					:edx)
+				 (:locally (:movl :edx (:edi (:edi-offset num-values))))
 				 (:stc))
 			       #+ignore
 			       (make-compiled-funcall-by-symbol 'muerte.cl::values




From ffjeld at common-lisp.net  Tue Jul 13 02:26:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:26:19 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BkCzr-0002cf-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Changed the run-time-context slot num-values from being lu32 to being
a word (i.e. a fixnum).

Date: Mon Jul 12 19:26:19 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.27 movitz/storage-types.lisp:1.28
--- movitz/storage-types.lisp:1.27	Mon Jul 12 04:09:12 2004
+++ movitz/storage-types.lisp	Mon Jul 12 19:26:19 2004
@@ -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.27 2004/07/12 11:09:12 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.28 2004/07/13 02:26:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -891,10 +891,12 @@
     :initform 0
     :accessor movitz-funobj-num-jumpers
     :map-binary-write (lambda (x &optional type)
-		       (declare (ignore typE))
-			(* x +movitz-fixnum-factor+))
+		       (declare (ignore type))
+		       (check-type x (unsigned-byte 14))
+		       (* x +movitz-fixnum-factor+))
     :map-binary-read (lambda (x &optional type)
-		       (declare (ignore typE))
+		       (declare (ignore type))
+		       (assert (zerop (ldb (byte 2 0) x)))
 		       (/ x +movitz-fixnum-factor+)))
    (num-constants
     :binary-type lu16




From ffjeld at common-lisp.net  Tue Jul 13 02:26:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:26:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1BkCzw-0002dI-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Changed the run-time-context slot num-values from being lu32 to being
a word (i.e. a fixnum).

Date: Mon Jul 12 19:26:24 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.12 movitz/losp/muerte/basic-functions.lisp:1.13
--- movitz/losp/muerte/basic-functions.lisp:1.12	Sun Jul 11 16:03:18 2004
+++ movitz/losp/muerte/basic-functions.lisp	Mon Jul 12 19:26:24 2004
@@ -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.12 2004/07/11 23:03:18 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.13 2004/07/13 02:26:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -279,9 +279,10 @@
    (3 (x y z)
       (with-inline-assembly (:returns :multiple-values)
 	(:compile-two-forms (:eax :ebx) x y)
-	((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values)))
-	(:compile-form (:result-mode :ecx) z)
-	((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'values)))
+	((:fs-override) :movl #.movitz:+movitz-fixnum-factor+
+			(:edi #.(movitz::global-constant-offset 'num-values)))
+	(:compile-form (:result-mode :edx) z)
+	((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values)))
 	(:movl 3 :ecx)
 	(:stc)))
    (t (&rest objects)
@@ -298,18 +299,19 @@
 	(:jz 'done)
 	(:subl 2 :ecx)
 	(:jc 'copy-done)
-	((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'num-values)))
+	(:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :edx)
+	((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'num-values)))
 	(:pushl :eax)
 	(:xorl :eax :eax)
        copy-loop
 	(:movl (:ebp (:ecx 4) 4) :edx)
-	((:fs-override) :movl :edx (:edi (:eax 4) #.(movitz::global-constant-offset 'values)))
-	(:addl 1 :eax)
+	((:fs-override) :movl :edx (:edi (:eax 1) #.(movitz::global-constant-offset 'values)))
+	(:addl 4 :eax)
 	(:subl 1 :ecx)
 	(:jnc 'copy-loop)
+	(:leal (:eax #.(cl:- movitz:+movitz-fixnum-factor+)) :ecx)
 	(:popl :eax)
-	((:fs-override) :movl (:edi #.(movitz::global-constant-offset 'num-values))
-			:ecx)
+	(:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
        copy-done
 	(:addl 2 :ecx)
 	(:jnz 'done)
@@ -333,7 +335,7 @@
 
 (define-compiler-macro object-location (object)
   "The location is the object's address divided by fixnum-factor."
-  `(with-inline-assembly (:returns :register)
+  `(with-inline-assembly (:returns :register :type fixnum)
      (:compile-form (:result-mode :register) ,object)
      (:andl ,(* -2 movitz::+movitz-fixnum-factor+) (:result-register))))
   




From ffjeld at common-lisp.net  Tue Jul 13 02:26:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:26:28 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BkD00-0002mw-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Changed the run-time-context slot num-values from being lu32 to being
a word (i.e. a fixnum).

Date: Mon Jul 12 19:26:28 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.26 movitz/losp/muerte/primitive-functions.lisp:1.27
--- movitz/losp/muerte/primitive-functions.lisp:1.26	Thu Jul  8 08:28:57 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Mon Jul 12 19:26:28 2004
@@ -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.26 2004/07/08 15:28:57 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.27 2004/07/13 02:26:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -713,6 +713,9 @@
     (:jnz 'push-loop)
    push-done
     (:locally (:movl (:edi (:edi-offset num-values)) :ecx))
+    (:testb 3 :cl)
+    (:jnz '(:sub-program () (:int 62)))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
     (:addl 2 :ecx)
    done
     (:jmp :edx)))
@@ -736,13 +739,15 @@
 	   (:jmp :edx)))
     ;; three or more values
     (:subl 2 :ecx)
+    (:shll #.movitz:+movitz-fixnum-shift+ :ecx)
     (:locally (:movl :ecx (:edi (:edi-offset num-values))))
-    (:subl 1 :ecx)
+    (:subl #.movitz:+movitz-fixnum-factor+ :ecx)
    pop-loop
-    (:locally (:popl (:edi (:ecx 4) (:edi-offset values))))
-    (:subl 1 :ecx)
+    (:locally (:popl (:edi (:ecx 1) (:edi-offset values))))
+    (:subl #.movitz:+movitz-fixnum-factor+ :ecx)
     (:jnc 'pop-loop)
     (:locally (:movl (:edi (:edi-offset num-values)) :ecx))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
     (:popl :ebx)
     (:popl :eax)
     (:addl 2 :ecx)




From ffjeld at common-lisp.net  Tue Jul 13 02:27:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:27:20 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp 
Message-ID: <E1BkD0q-0003Q8-00@common-lisp.net>

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

Modified Files:
	cpu-id.lisp 
Log Message:
Removed some dead code.

Date: Mon Jul 12 19:27:20 2004
Author: ffjeld

Index: movitz/losp/muerte/cpu-id.lisp
diff -u movitz/losp/muerte/cpu-id.lisp:1.5 movitz/losp/muerte/cpu-id.lisp:1.6
--- movitz/losp/muerte/cpu-id.lisp:1.5	Wed Jun  2 16:49:27 2004
+++ movitz/losp/muerte/cpu-id.lisp	Mon Jul 12 19:27:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Apr 15 22:47:13 2002
 ;;;;                
-;;;; $Id: cpu-id.lisp,v 1.5 2004/06/02 23:49:27 ffjeld Exp $
+;;;; $Id: cpu-id.lisp,v 1.6 2004/07/13 02:27:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -216,31 +216,6 @@
      (do-case (t :multiple-values)
        (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter)))))
 		      
-
-;;;(defun read-time-stamp-counter ()
-;;;  "Read the 64-bit i686 time-stamp counter.
-;;;Returned as three values: low 24 bits, mid 24 bits, high 16 bits.
-;;;This is an illegal instruction on lesser CPUs."
-;;;  (with-inline-assembly (:returns :multiple-values)
-;;;    (:std)
-;;;    (:rdtsc)				; Read Time-Stamp Counter into EDX:EAX
-;;;    ;; Load upper 16 bits (of EDX) as ternary value.
-;;;    (:movl :edx :ecx)
-;;;    (:andl #xffff0000 :edx)
-;;;    (:shll #.(cl:- 16 movitz::+movitz-fixnum-shift+) :edx)
-;;;    ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values)))
-;;;    ;; Bits 24-47 as fixnum into EBX
-;;;    (:shldl #.(cl:+ 8 movitz::+movitz-fixnum-shift+) :eax :ebx)
-;;;    (:andl #.(cl:* #x00ffffff movitz::+movitz-fixnum-factor+) :ebx)
-;;;    ;; Bits 0-23 as fixnum into EAX
-;;;    (:andl #x00ffffff :eax)
-;;;    (:shll #.movitz::+movitz-fixnum-shift+ :eax)
-;;;    (:cld)
-;;;    ;; Return 3 values
-;;;    ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values)))
-;;;    (:movl 3 :ecx)
-;;;    (:stc)))
-
 (defun clear-time-stamp-counter ()
   "Reset the i686 time-stamp-counter.
 This is an illegal instruction on lesser CPUs, and a no-op on some, such as bochs."
@@ -256,9 +231,6 @@
      (:popl (:result-register))
      (:movl (:result-register) (#x1000))
      (:shll 2 (:result-register))))
-;;;     (:popl :ecx)
-;;;     (:leal ((:ecx ,movitz::+movitz-fixnum-factor+) :edi ,(movitz::edi-offset))
-;;;	    (:result-register))))
 
 (defun eflags ()
   (eflags))




From ffjeld at common-lisp.net  Tue Jul 13 02:29:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:29:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkD2h-0007c0-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
More bignum fixes. Added some slow-but-working implementations of *
and truncate for bignums.

Date: Mon Jul 12 19:29:15 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.47 movitz/losp/muerte/integers.lisp:1.48
--- movitz/losp/muerte/integers.lisp:1.47	Mon Jul 12 07:17:14 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 19:29:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.47 2004/07/12 14:17:14 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.48 2004/07/13 02:29:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -68,6 +68,36 @@
 (defun oddp (x)
   (not (evenp x)))
 
+
+
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype signed-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    'integer)
+   ((typep size '(integer 1 *))
+    (list 'integer
+	  (- (ash 1 (1- size)))
+	  (1- (ash 1 (1- size)))))
+   (t (error "Illegal size for signed-byte."))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    (list 'integer 0 (1- (ash 1 size))))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
 ;;; Addition
 
 (define-compiler-macro + (&whole form &rest operands &environment env)
@@ -400,7 +430,7 @@
 			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
 			(:cmpb ,(movitz:tag :bignum) :cl)
 			(:jne 'not-a-number)
-			(:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
+			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
 			(:jne 'not-most-negative-fixnum)
 			(:cmpl ,(- most-negative-fixnum)
 			 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
@@ -423,15 +453,50 @@
 		)))
 	(do-it)))
    (2 (minuend subtrahend)
-      (cond
-       ((eq 0 minuend)
-	(- subtrahend))
-       (t (check-type minuend fixnum)
-	  (check-type subtrahend fixnum)
-	  (with-inline-assembly (:returns :eax :side-effects nil)
-	    (:compile-two-forms (:eax :ebx) minuend subtrahend)
-	    (:subl :ebx :eax)
-	    (:into)))))
+      (macrolet
+	  ((do-it ()
+	     `(number-double-dispatch (minuend subtrahend)
+		((t (eql 0))
+		 minuend)
+		(((eql 0) t)
+		 (- subtrahend))
+		((fixnum fixnum)
+		 (with-inline-assembly (:returns :eax :side-effects nil)
+		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
+		   (:subl :ebx :eax)
+		   (:into)))
+		((bignum fixnum)
+		 (+ (- subtrahend) minuend))
+		((fixnum bignum)
+		 (- (+ (- minuend) subtrahend)))
+		((positive-bignum positive-bignum)
+		 (cond
+		  ((= minuend subtrahend)
+		   0)
+		  ((< minuend subtrahend)
+		   (- (- subtrahend minuend)))
+		  (t (%bignum-canonicalize
+		      (with-inline-assembly (:returns :eax)
+			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
+			(:xorl :edx :edx) ; counter
+			(:xorl :ecx :ecx) ; carry
+		       sub-loop
+			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			       :ecx)
+			(:sbbl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:sbbl :ecx :ecx)
+			(:negl :ecx)
+			(:addl 4 :edx)
+			(:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			(:jne 'sub-loop)
+			(:subl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jc '(:sub-program (should-not-happen)
+			       (:int 107)))
+			)))))
+		)))
+	(do-it)))
    (t (minuend &rest subtrahends)
       (declare (dynamic-extent subtrahends))
       (if subtrahends
@@ -1025,34 +1090,6 @@
 ;;;      (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al)))
 ;;;   (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count)))))
 
-;;; Types
-
-(define-typep integer (x &optional (min '*) (max '*))
-  (and (typep x 'integer)
-       (or (eq min '*) (<= min x))
-       (or (eq max '*) (<= x max))))
-
-(deftype signed-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    'integer)
-   ((typep size '(integer 1 *))
-    (list 'integer
-	  (- (ash 1 (1- size)))
-	  (1- (ash 1 (1- size)))))
-   (t (error "Illegal size for signed-byte."))))
-
-(deftype unsigned-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    '(integer 0))
-   ((typep size '(integer 1 *))
-    (list 'integer 0 (1- (ash 1 size))))
-   (t (error "Illegal size for unsigned-byte."))))
-
-(define-simple-typep (bit bitp) (x)
-  (or (eq x 0) (eq x 1)))
-
 ;;;;
 
 (defun integer-length (integer)
@@ -1267,10 +1304,11 @@
 		    positive-result
 		     )))
 		((positive-bignum positive-bignum)
-		 (do ((f y)
+		 (do ((mx (* most-positive-fixnum x))
+		      (f y)
 		      (r 0))
 		     ((typep f 'fixnum) (+ r (* f x)))
-		   (setf r (+ r (* most-positive-fixnum x)))
+		   (setf r (+ r mx))
 		   (setf f (- f most-positive-fixnum))))
 		)))
 	(do-it)))
@@ -1402,7 +1440,9 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (error "Don't know how to divide ~S with ~S." number divisor))))
+	  (t (do ((q 0 (1+ q))
+		  (r number (- r divisor)))
+		 ((< r divisor) (values q r))))))
 	))))
 
 (defun / (number &rest denominators)




From ffjeld at common-lisp.net  Tue Jul 13 02:31:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:31:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BkD4m-0005zt-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Don't use funcall%unsafe (yet).

Date: Mon Jul 12 19:31:24 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.12 movitz/losp/muerte/los-closette.lisp:1.13
--- movitz/losp/muerte/los-closette.lisp:1.12	Thu Jul  8 11:53:52 2004
+++ movitz/losp/muerte/los-closette.lisp	Mon Jul 12 19:31:24 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.12 2004/07/08 18:53:52 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.13 2004/07/13 02:31:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -577,9 +577,6 @@
 		 (third active-specializers)
 		 emfun)
 	  (std-gf-classes-to-emf-table gf))
-;;;    (when (< 4 (length (std-gf-classes-to-emf-table gf)))
-;;;      (warn "method cache size for ~S: ~D"
-;;;	    gf (length (std-gf-classes-to-emf-table gf))))
     (apply emfun args)))
 
 (defun cached-lookup-failed-map1111 (gf &rest args)
@@ -592,9 +589,6 @@
 		 (fourth active-specializers)
 		 emfun)
 	  (std-gf-classes-to-emf-table gf))
-;;;    (when (< 4 (length (std-gf-classes-to-emf-table gf)))
-;;;      (warn "method cache size for ~S: ~D"
-;;;	    gf (length (std-gf-classes-to-emf-table gf))))
     (apply emfun args)))
 
 (defun discriminating-function-map1-no-eqls (&edx gf arg0 &rest optional-args)
@@ -604,19 +598,19 @@
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map1 gf arg0 class))
 	  (when (eq class (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0))))))
+	    (return (funcall (cdr entry) arg0))))))
    (2 (&edx gf arg0 optional1)
       (let ((class (class-of arg0)))
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map1 gf arg0 class optional1))
 	  (when (eq class (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0 optional1))))))
+	    (return (funcall (cdr entry) arg0 optional1))))))
    (3 (&edx gf arg0 optional1 optional2)
       (let ((class (class-of arg0)))
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map1 gf arg0 class optional1 optional2))
 	  (when (eq class (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0 optional1 optional2))))))
+	    (return (funcall (cdr entry) arg0 optional1 optional2))))))
    (t (&edx gf arg0 &rest optional-args)
       (declare (dynamic-extent optional-args))
       (let ((class (class-of arg0)))
@@ -634,7 +628,7 @@
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map1 gf arg0 specializer))
 	  (when (eq specializer (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0))))))
+	    (return (funcall (cdr entry) arg0))))))
    (2 (&edx gf arg0 optional1)
       (let* ((es-table (car (std-gf-eql-specializer-table gf)))
 	     (specializer (or (and es-table (gethash arg0 es-table))
@@ -642,7 +636,7 @@
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map1 gf arg0 specializer optional1))
 	  (when (eq specializer (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0 optional1))))))
+	    (return (funcall (cdr entry) arg0 optional1))))))
    (t (&edx gf arg0 &rest optional-args)
       (declare (dynamic-extent optional-args))
       (let* ((es-table (car (std-gf-eql-specializer-table gf)))
@@ -661,13 +655,13 @@
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map10 gf arg0 arg1 (class-of arg0) class))
 	  (when (eq class (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0 arg1))))))
+	    (return (funcall (cdr entry) arg0 arg1))))))
    (3 (&edx gf arg0 arg1 optional2)
       (let ((class (class-of arg1)))
 	(dolist (entry (std-gf-classes-to-emf-table gf)
 		  (cached-lookup-failed-map10 gf arg0 arg1 (class-of arg0) class optional2))
 	  (when (eq class (car entry))
-	    (return (funcall%unsafe (cdr entry) arg0 arg1 optional2))))))
+	    (return (funcall (cdr entry) arg0 arg1 optional2))))))
    (t (&edx gf arg0 arg1 &rest optional-args)
       (declare (dynamic-extent optional-args))
       (let ((class (class-of arg1)))
@@ -688,7 +682,7 @@
 	  (let ((e entry))
 	    (when (and (eq class0 (pop e))
 		       (eq class1 (pop e)))
-	      (return (funcall%unsafe e arg0 arg1)))))))
+	      (return (funcall e arg0 arg1)))))))
    (3 (&edx gf arg0 arg1 optional2)
       (let ((class0 (class-of arg0))
 	    (class1 (class-of arg1)))
@@ -697,7 +691,7 @@
 	  (let ((e entry))
 	    (when (and (eq class0 (pop e))
 		       (eq class1 (pop e)))
-	      (return (funcall%unsafe e arg0 arg1 optional2)))))))
+	      (return (funcall e arg0 arg1 optional2)))))))
    (t (&edx gf arg0 arg1 &rest optional-args)
       (declare (dynamic-extent optional-args))
       (let ((class0 (class-of arg0))
@@ -720,7 +714,7 @@
 	  (let ((e entry))
 	    (when (and (eq class0 (pop e))
 		       (eq class2 (pop e)))
-	      (return (funcall%unsafe e arg0 arg1 arg2)))))))
+	      (return (funcall e arg0 arg1 arg2)))))))
    (t (&edx gf arg0 arg1 arg2 &rest optional-args)
       (declare (dynamic-extent optional-args))
       (let ((class0 (class-of arg0))




From ffjeld at common-lisp.net  Tue Jul 13 02:37:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:37:37 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BkDAn-0008G0-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Some debugging tweaks to map-heap-words.

Date: Mon Jul 12 19:37:36 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.15 movitz/losp/muerte/scavenge.lisp:1.16
--- movitz/losp/muerte/scavenge.lisp:1.15	Mon Jul 12 04:09:34 2004
+++ movitz/losp/muerte/scavenge.lisp	Mon Jul 12 19:37:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.15 2004/07/12 11:09:34 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.16 2004/07/13 02:37:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -63,7 +63,7 @@
 	  (error "Illegal word ~Z at ~S." x scan))
 	 ((scavenge-typep x :bignum)
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd address #x~X." x scan)
 	  ;; Just skip the bigits
 	  (let* ((bigits (word-bigits x))
 		 (delta (1+ (logand bigits -2))))
@@ -71,9 +71,9 @@
 	    (incf scan delta)))
 	 ((scavenge-typep x :funobj)
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd address #x~X." x scan)
 	  (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
-	  ;; Process code-vector pointer specially..
+	  ;; Process code-vector pointers specially..
 	  (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
 		 (code-vector (funobj-code-vector funobj))
 		 (num-jumpers (funobj-num-jumpers funobj)))
@@ -98,21 +98,21 @@
 	      (scavenge-wide-typep x :basic-vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :code)))
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd address #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
@@ -125,7 +125,9 @@
 	  (error "Scanned old-vector #x~Z at address #x~X." x scan))
 	 ((eq x (fixnum-word 3))
 	  (incf scan)
-	  (incf scan (memref scan 0 0 :lisp)))
+	  (let ((delta (memref scan 0 0 :lisp)))
+	    (check-type delta positive-fixnum)
+	    (incf scan delta)))
 	 ((typep x 'pointer)
 	  (let ((new (funcall function x scan)))
 	    (unless (eq new x)




From ffjeld at common-lisp.net  Tue Jul 13 02:38:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:38:27 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BkDBb-0003JM-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Commented out some debugging code that shouldn't be running.

Date: Mon Jul 12 19:38:27 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.23 movitz/losp/los0-gc.lisp:1.24
--- movitz/losp/los0-gc.lisp:1.23	Mon Jul 12 04:11:15 2004
+++ movitz/losp/los0-gc.lisp	Mon Jul 12 19:38:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.23 2004/07/12 11:11:15 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.24 2004/07/13 02:38:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -390,6 +390,7 @@
 			       (+ newspace-location (space-fresh-pointer newspace)))
 	       (setf scan-pointer fresh-pointer))
 
+	#+ignore
 	(dotimes (i (truncate (length *x*) 2))
 	  (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6))
 		(y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6)))




From ffjeld at common-lisp.net  Tue Jul 13 02:39:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 12 Jul 2004 19:39:13 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1BkDCL-0005y4-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Minor edits. Added a rather bad implementation of random.

Date: Mon Jul 12 19:39:13 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.18 movitz/losp/los0.lisp:1.19
--- movitz/losp/los0.lisp:1.18	Mon Jul 12 01:41:23 2004
+++ movitz/losp/los0.lisp	Mon Jul 12 19:39:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.18 2004/07/12 08:41:23 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.19 2004/07/13 02:39:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -114,9 +114,6 @@
 ;;;    (:leal (:edi -4) :eax)
 ;;;    (:rorb :cl :al)))
 
-(defun foo (x)
-  (foo x x))
-
 
 #+ignore
 (defun test-block (x)
@@ -299,13 +296,6 @@
 	    (- (object-location bar) (object-location result))))
     (values foo result bar)))
 
-(defun foo (number &rest more-numbers)
-  (declare (dynamic-extent more-numbers))
-  (do ((p more-numbers (cdr p)))
-      ((not (cdr p)) number)
-    (unless (< (car p) (cadr p))
-      (return nil))))
-
 (defun modx (x)
   (lambda ()
     (print x)))
@@ -693,12 +683,6 @@
 (defun test-nano-sleep (x)
   (time (nano-sleep x)))
 
-(defun mvtest ()
-  (multiple-value-call #'list (round 5 2))
-  (list (memref-int #x1000000 0 0 :unsigned-byte8)
-	(memref-int #x1000004 0 0 :unsigned-byte8)))
-
-
 ;;;;;
 
 ;;;;;;;;;;;;;;; CL
@@ -974,6 +958,20 @@
     (loop
       (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
 	(read-eval-print)))))
+
+(defun random (limit)
+  (etypecase limit
+    (fixnum
+     (rem (read-time-stamp-counter) limit))
+    (muerte::positive-bignum
+     (let ((x (muerte::copy-bignum limit)))
+       (dotimes (i (1- (muerte::%bignum-bigits x)))
+	 (setf (memref x 2 i :unsigned-byte32)
+	   (muerte::read-time-stamp-counter)))
+       (setf x (muerte::%bignum-canonicalize x))
+       (loop while (>= x limit)
+	   do (setf x (truncate x 2)))
+       x))))
 
 (defun genesis ()
   #+ignore




From ffjeld at common-lisp.net  Tue Jul 13 12:59:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 05:59:33 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BkMsf-0003jk-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Correct the calculation of protect-non-pointer-count in
run-time-context. This bug broke GC severely.

Date: Tue Jul 13 05:59:33 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.45 movitz/image.lisp:1.46
--- movitz/image.lisp:1.45	Mon Jul 12 19:24:36 2004
+++ movitz/image.lisp	Tue Jul 13 05:59:33 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.45 2004/07/13 02:24:36 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.46 2004/07/13 12:59:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -398,8 +398,11 @@
     :initform 3)
    (protect-non-pointer-count
     :binary-type lu32
-    :initform (* 4 (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end)
-		      (bt:slot-offset 'movitz-constant-block 'non-pointers-start))))
+    :initform nil
+    :map-binary-write (lambda (x type)
+			(declare (ignore x type))
+			(- (bt:slot-offset 'movitz-constant-block 'non-pointers-end)
+			   (bt:slot-offset 'movitz-constant-block 'non-pointers-start))))
    (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START =======
    ;; (align-segment-descriptors :binary-type 4)
    (segment-descriptor-table :binary-type :label)




From ffjeld at common-lisp.net  Tue Jul 13 13:00:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 06:00:11 -0700
Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt 
Message-ID: <E1BkMtH-0008BM-00@common-lisp.net>

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

Modified Files:
	bochsrc.txt 
Log Message:
Configure bochs with 64 MB to allow experimentation with more memory.

Date: Tue Jul 13 06:00:11 2004
Author: ffjeld

Index: movitz/bochsrc.txt
diff -u movitz/bochsrc.txt:1.2 movitz/bochsrc.txt:1.3
--- movitz/bochsrc.txt:1.2	Fri May 21 02:40:09 2004
+++ movitz/bochsrc.txt	Tue Jul 13 06:00:10 2004
@@ -3,7 +3,7 @@
 ###############################################################
 
 # how much memory the emulated machine will have
-megs: 32
+megs: 64
 
 # filename of ROM images
 #romimage: file=/usr/local/bochs/1.2.1/BIOS-bochs-latest, address=0xf0000




From ffjeld at common-lisp.net  Tue Jul 13 13:00:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 06:00:37 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BkMth-0001z1-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Minor edit.

Date: Tue Jul 13 06:00:37 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.16 movitz/losp/muerte/scavenge.lisp:1.17
--- movitz/losp/muerte/scavenge.lisp:1.16	Mon Jul 12 19:37:36 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 13 06:00:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.16 2004/07/13 02:37:36 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.17 2004/07/13 13:00:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -127,6 +127,7 @@
 	  (incf scan)
 	  (let ((delta (memref scan 0 0 :lisp)))
 	    (check-type delta positive-fixnum)
+	    ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta))
 	    (incf scan delta)))
 	 ((typep x 'pointer)
 	  (let ((new (funcall function x scan)))




From ffjeld at common-lisp.net  Tue Jul 13 13:02:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 06:02:46 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BkMvm-0006eu-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Changed the GC messages a bit, and added the feature of polling the
keyboard for ESC (if pressed, break) after each GC stop-and-copy cycle.

Date: Tue Jul 13 06:02:45 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.24 movitz/losp/los0-gc.lisp:1.25
--- movitz/losp/los0-gc.lisp:1.24	Mon Jul 12 19:38:27 2004
+++ movitz/losp/los0-gc.lisp	Tue Jul 13 06:02:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.24 2004/07/13 02:38:27 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.25 2004/07/13 13:02:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -247,8 +247,12 @@
     (setf (exception-handler 113)
       (lambda (exception interrupt-frame)
 	(declare (ignore exception interrupt-frame))
-	(format t "~&;; Handling out-of-memory exception..")
-	(stop-and-copy)))
+	(format t "~&;; GC.. ")
+	(stop-and-copy)
+	;; This is  a nice opportunity to poll the keyboard..
+	(case (muerte.x86-pc.keyboard:poll-char)
+	  ((#\esc)
+	   (break "Los0 GC keyboard poll.")))))
     (let ((conser (symbol-value 'los0-fast-cons)))
       (check-type conser vector)
       (setf (%run-time-context-slot 'muerte::fast-cons)
@@ -365,7 +369,7 @@
 			   (vector-push (object-location x) *x*)
 			   (vector-push (object-location fw) *x*)
 			   fw))))
-		    (t (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))
+		    (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
 			 (if (object-in-space-p newspace forwarded-x)
 			     (progn
 			       (assert (eq (object-tag forwarded-x)
@@ -374,7 +378,7 @@
 			   (let ((forward-x (shallow-copy x)))
 			     (when (typep x 'muerte::bignum)
 			       (assert (= x forward-x)))
-			     (setf (memref (object-location x) 0 1 :lisp) forward-x)
+			     (setf (memref (object-location x) 0 0 :lisp) forward-x)
 			     forward-x)))))))))
 	;; Scavenge roots
 	(map-heap-words evacuator 0 (+ (malloc-buffer-start)
@@ -404,7 +408,7 @@
 	;; GC completed, oldspace is evacuated.
 	(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
 	      (new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))
-	  (format t "~&;; Old space: ~/muerte:pprint-clumps/, new space: ~
+	  (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		  old-size new-size (- old-size new-size)))
 	(initialize-space oldspace))))




From ffjeld at common-lisp.net  Tue Jul 13 13:05:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 06:05:23 -0700
Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog 
Message-ID: <E1BkMyJ-00067M-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Tue Jul 13 06:05:23 2004
Author: ffjeld

Index: movitz/doc/ChangeLog
diff -u movitz/doc/ChangeLog:1.6 movitz/doc/ChangeLog:1.7
--- movitz/doc/ChangeLog:1.6	Mon Jul 12 02:11:24 2004
+++ movitz/doc/ChangeLog	Tue Jul 13 06:05:23 2004
@@ -1,3 +1,10 @@
+2004-07-13  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added the feature that after each GC cycle, the keyboard is
+	polled. If the escape key is entered, a break to the debugger is
+	performed. This way one can interrupt long-running executions, so
+	long as the GC is triggered once in a while.
+
 2004-07-12  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Added top-level-command :more, that will evaluate a form while




From ffjeld at common-lisp.net  Tue Jul 13 13:41:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 06:41:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkNX3-0000Zy-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Implement bignum multiplication with a linear rather than a quadratic
algorithm. Quite a bit faster..

Date: Tue Jul 13 06:41:17 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.48 movitz/losp/muerte/integers.lisp:1.49
--- movitz/losp/muerte/integers.lisp:1.48	Mon Jul 12 19:29:15 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 13 06:41:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.48 2004/07/13 02:29:15 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.49 2004/07/13 13:41:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1231,6 +1231,7 @@
 		    fixnum-done)))
 		(((eql 0) t) 0)
 		(((eql 1) t) y)
+		(((eql -1) t) (- y))
 		((t fixnum) (* y x))
 		((fixnum bignum)
 		 (let (r)
@@ -1304,13 +1305,15 @@
 		    positive-result
 		     )))
 		((positive-bignum positive-bignum)
-		 (do ((mx (* most-positive-fixnum x))
-		      (f y)
-		      (r 0))
-		     ((typep f 'fixnum) (+ r (* f x)))
-		   (setf r (+ r mx))
-		   (setf f (- f most-positive-fixnum))))
-		)))
+		 (if (< x y)
+		     (* y x)
+		   ;; X is the biggest factor.
+		   (let ((r 0) (f 0))
+		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
+		       (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
+				    f))
+		       (incf f 16))
+		     r))))))
 	(do-it)))
    (t (&rest factors)
       (declare (dynamic-extent factors))




From ffjeld at common-lisp.net  Tue Jul 13 14:06:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 07:06:57 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1BkNvt-0006cX-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Accessors symbol-special-variable-p and symbol-constant-variable-p
were out of sync with storage-types.lisp. This caused e.g. let of
special variables not to work in the REPL.

Date: Tue Jul 13 07:06:57 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.15 movitz/losp/muerte/symbols.lisp:1.16
--- movitz/losp/muerte/symbols.lisp:1.15	Wed Jul  7 16:22:16 2004
+++ movitz/losp/muerte/symbols.lisp	Tue Jul 13 07:06:56 2004
@@ -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.15 2004/07/07 23:22:16 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.16 2004/07/13 14:06:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -195,18 +195,18 @@
      flags)))
 
 (defun symbol-special-variable-p (symbol)
-  (logbitp 0 (symbol-flags symbol)))
+  (logbitp 3 (symbol-flags symbol)))
 
 (defun (setf symbol-special-variable-p) (value symbol)
-  (setf (ldb (byte 1 0) (symbol-flags symbol))
+  (setf (ldb (byte 1 3) (symbol-flags symbol))
     (if value 1 0))
   value)
 
 (defun symbol-constant-variable-p (symbol)
-  (logbitp 1 (symbol-flags symbol)))
+  (logbitp 4 (symbol-flags symbol)))
 
 (defun (setf symbol-constant-variable-p) (value symbol)
-  (setf (ldb (byte 1 1) (symbol-flags symbol))
+  (setf (ldb (byte 1 4) (symbol-flags symbol))
     (if value 1 0))
   value)
 




From ffjeld at common-lisp.net  Tue Jul 13 14:17:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 07:17:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkO5h-0003xh-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Made defun ash slightly smarter. Also, in the * compiler-macro, never
implement * in terms of ash.

Date: Tue Jul 13 07:17:05 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.49 movitz/losp/muerte/integers.lisp:1.50
--- movitz/losp/muerte/integers.lisp:1.49	Tue Jul 13 06:41:17 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 13 07:17:05 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.49 2004/07/13 13:41:17 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.50 2004/07/13 14:17:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1064,32 +1064,14 @@
 (defun ash (integer count)
   (cond
    ((not (minusp count))
+    (do () ((< count 16))
+      (setf integer (no-macro-call * #x10000 integer))
+      (decf count 16))
     (dotimes (i count integer)
       (setf integer (no-macro-call * 2 integer))))
    (t (dotimes (i (- count) integer)
 	(setf integer (truncate integer 2))))))
 
-;;;(defun ash (integer count)
-;;;  (check-type integer fixnum)
-;;;  (check-type count fixnum)
-;;;  (cond
-;;;   ((= 0 count)
-;;;    integer)
-;;;   ((<= 1 count 29)
-;;;    (dotimes (i count integer)
-;;;      (setq integer (ash integer 1))))
-;;;   ((<= count #.(cl:- 1 movitz::+movitz-fixnum-bits+))
-;;;    (if (minusp integer) -1 0))
-;;;   ((minusp count)
-;;;    (with-inline-assembly (:returns :eax)
-;;;      (:compile-form (:result-mode :ecx) count)
-;;;      (:compile-form (:result-mode :eax) integer)
-;;;      (:negl :ecx)
-;;;      (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-;;;      (:sarl :cl :eax)
-;;;      (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al)))
-;;;   (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count)))))
-
 ;;;;
 
 (defun integer-length (integer)
@@ -1150,7 +1132,6 @@
 	     (case f1
 	       (0 `(progn ,factor2 0))
 	       (1 factor2)
-	       (2 `(ash ,factor2 1))
 	       (t `(no-macro-call * ,factor1 ,factor2)))))
 	  (t `(no-macro-call * ,factor1 ,factor2)))))
     (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))




From ffjeld at common-lisp.net  Tue Jul 13 14:28:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 07:28:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1BkOGL-0004gf-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Added some extra-safe checking to %bignum-bigits.

Date: Tue Jul 13 07:28:05 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.12 movitz/losp/muerte/more-macros.lisp:1.13
--- movitz/losp/muerte/more-macros.lisp:1.12	Mon Jul 12 04:09:29 2004
+++ movitz/losp/muerte/more-macros.lisp	Tue Jul 13 07:28:05 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.12 2004/07/12 11:09:29 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.13 2004/07/13 14:28:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -312,7 +312,9 @@
   `(with-inline-assembly (:returns :eax :type (unsigned-byte 14))
      (:compile-form (:result-mode :eax) ,x)
      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-	      :eax)))
+	      :eax)
+     (:testb 3 :al)			; Just to be sure..
+     (:jnz '(:sub-program () (:int 63)))))
 
 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 




From ffjeld at common-lisp.net  Tue Jul 13 14:29:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 07:29:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BkOHb-00010i-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Minor edit.

Date: Tue Jul 13 07:29:22 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.18 movitz/losp/muerte/inspect.lisp:1.19
--- movitz/losp/muerte/inspect.lisp:1.18	Mon Jul 12 19:21:08 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 13 07:29:22 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.18 2004/07/13 02:21:08 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.19 2004/07/13 14:29:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -322,7 +322,7 @@
      copy-bignum-loop
       (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx)
       (:movl :ecx (:eax :edx #.movitz:+other-type-offset+))
-      (:subl #.movitz:+movitz-fixnum-factor+ :edx)
+      (:subl 4 :edx)
       (:jnc 'copy-bignum-loop))))
 
 (defun print-bignum (x)




From ffjeld at common-lisp.net  Tue Jul 13 19:45:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 12:45:39 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkTDf-0001hf-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Two fixes: Comparison of bignums was flawed, because the bigits were
compared as signed values, while they in fact are unsigned. So <, >,
=, etc would return the wrong answer in 50% of the cases.
Secondly, added a linear-complexity algorithm for truncate, rather
than the idiotic quadratic one.

Date: Tue Jul 13 12:45:38 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.50 movitz/losp/muerte/integers.lisp:1.51
--- movitz/losp/muerte/integers.lisp:1.50	Tue Jul 13 07:17:05 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 13 12:45:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.50 2004/07/13 14:17:05 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.51 2004/07/13 19:45:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -570,12 +570,22 @@
 	    (:cmpl :ecx
 		   (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 	    (:je 'positive-compare-loop)
-	    (:ret)
-	   positive-compare-lsb		; it's down to the LSB bigits.
-	    (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	   positive-compare-lsb
+	    ;; Now make the compare unsigned..
+	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)		; First compare upper 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)
+	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
+	    (:jne 'upper-16-decisive)
+	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
+	   upper-16-decisive
 	    (:ret)
 	    
 	   compare-negatives
@@ -1424,10 +1434,23 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (do ((q 0 (1+ q))
-		  (r number (- r divisor)))
-		 ((< r divisor) (values q r))))))
-	))))
+	  (t (let* ((msb-pos (1- (* 2 (%bignum-bigits divisor))))
+		    (msb (memref divisor -2 msb-pos :unsigned-byte16)))
+	       (when (= 0 msb)
+		 (decf msb-pos)
+		 (setf msb (memref divisor -2 msb-pos :unsigned-byte16))
+		 (assert (plusp msb)))
+	       (do ((msb+1 (1+ msb))
+		    (q 0) (r number))
+		   ((< r divisor) (values q r))
+		 (let ((guess (truncate r msb+1)))
+		   (dotimes (i msb-pos)
+		     (setf guess (truncate guess #x10000)))
+		   (if (= 0 guess)
+		       (setf q (1+ q)
+			     r (- r divisor))
+		     (setf q (+ q guess)
+			   r (- r (* divisor guess))))))))))))))
 
 (defun / (number &rest denominators)
   (declare (dynamic-extent denominators))




From ffjeld at common-lisp.net  Tue Jul 13 21:01:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 14:01:42 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkUPG-0003oF-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added a non-square-complexity isqrt.

Date: Tue Jul 13 14:01:42 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.51 movitz/losp/muerte/integers.lisp:1.52
--- movitz/losp/muerte/integers.lisp:1.51	Tue Jul 13 12:45:38 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 13 14:01:42 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.51 2004/07/13 19:45:38 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.52 2004/07/13 21:01:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2365,9 +2365,18 @@
 
 (defun isqrt (natural)
   "=> natural-root"
-  (check-type natural (integer 0 *))
-  (do ((i 0 (1+ i)))
-      ((> (* i i) natural) (1- i))))
+  (etypecase natural
+    ((eql 0) 0)
+    ((integer 1 *)
+     (let ((r 1))
+       (do ((next-r (truncate (+ r (truncate natural r)) 2)
+		    (truncate (+ r (truncate natural r)) 2)))
+	   ((typep (- next-r r) '(integer 0 1))
+	    (let ((r+1 (1+ r)))
+	      (if (<= (* r+1 r+1) natural)
+		  r+1
+		r)))
+	 (setf r next-r))))))
 
 (define-compiler-macro expt (&whole form base-number power-number &environment env)
   (if (not (and (movitz:movitz-constantp base-number env)




From ffjeld at common-lisp.net  Tue Jul 13 22:41:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:41:07 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BkVxT-0001nA-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Changed make-stack-setup-code to push any number of EDIs rather than
subtracting from ESP, so as to keep the stack GC-safe. I don't know if
this is a viable long-term solution to this problem, though.

Date: Tue Jul 13 15:41:07 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.74 movitz/compiler.lisp:1.75
--- movitz/compiler.lisp:1.74	Mon Jul 12 02:11:07 2004
+++ movitz/compiler.lisp	Tue Jul 13 15:41:06 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.74 2004/07/12 09:11:07 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.75 2004/07/13 22:41:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1175,14 +1175,6 @@
 ;;;	       (t (warn "1-req-1-opt failed"))))))
 ;;;	 (t nil))))))
 
-
-(defun make-compiled-stack-frame-init (stack-frame-init)
-  (case stack-frame-init
-    (0 nil)
-    (1 '((:pushl :edi)))
-    (2 '((:pushl :edi) (:pushl :edi)))
-    (t `((:subl ,(* 4 stack-frame-init) :esp)))))
-
 (defun movitz-compile-file (path &key ((:image *image*) *image*)
 				   load-priority
 				   (delete-file-p nil))
@@ -3895,6 +3887,9 @@
 	       min-args max-args)))))
 
 (defun make-stack-setup-code (stack-setup-size)
+  (loop repeat stack-setup-size
+      collect '(:pushl :edi))
+  #+ignore
   (case stack-setup-size
     (0 nil)
     (1 '((:pushl :edi)))




From ffjeld at common-lisp.net  Tue Jul 13 22:41:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:41:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1BkVy8-0004MW-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Added a continuation to unbound-function.

Date: Tue Jul 13 15:41:48 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.14 movitz/losp/muerte/functions.lisp:1.15
--- movitz/losp/muerte/functions.lisp:1.14	Wed Jul  7 10:37:43 2004
+++ movitz/losp/muerte/functions.lisp	Tue Jul 13 15:41:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.14 2004/07/07 17:37:43 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.15 2004/07/13 22:41:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -83,9 +83,11 @@
 			 (compiled-function
 			  (funobj-name edx))
 			 (t '(unknown)))))
-    (error 'undefined-function-call
-	   :name function-name
-	   :arguments (copy-list args))))
+    (with-simple-restart (continue "Return NIL from ~S." function-name)
+      (error 'undefined-function-call
+	     :name function-name
+	     :arguments (copy-list args))))
+  nil)
 
 ;;; funobj object
 




From ffjeld at common-lisp.net  Tue Jul 13 22:42:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:42:39 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BkVyx-0005LM-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Sigh.. another bug in copy-bignum. Now I do hope it's correct.

Date: Tue Jul 13 15:42:39 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.19 movitz/losp/muerte/inspect.lisp:1.20
--- movitz/losp/muerte/inspect.lisp:1.19	Tue Jul 13 07:29:22 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 13 15:42:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.19 2004/07/13 14:29:22 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.20 2004/07/13 22:42:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -315,7 +315,7 @@
 (defun copy-bignum (old)
   (check-type old bignum)
   (let* ((length (%bignum-bigits old))
-	 (new (malloc-data-words length)))
+	 (new (malloc-data-clumps (1+ (truncate length 2)))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
       (:compile-form (:result-mode :edx) length)




From ffjeld at common-lisp.net  Tue Jul 13 22:43:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:43:40 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkVzw-0004fY-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Implement the fact that (truncate fixnum bignum) results in (values 0 fixnum).

Date: Tue Jul 13 15:43:40 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.52 movitz/losp/muerte/integers.lisp:1.53
--- movitz/losp/muerte/integers.lisp:1.52	Tue Jul 13 14:01:42 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 13 15:43:40 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.52 2004/07/13 21:01:42 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.53 2004/07/13 22:43:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1335,6 +1335,8 @@
 	   (:xorl :ecx :ecx)
 	   (:movb 2 :cl)		; return values: qutient, remainder.
 	   (:stc)))
+	((positive-fixnum positive-bignum)
+	 (values 0 number))
 	((positive-bignum positive-fixnum)
 	 (macrolet
 	     ((do-it ()




From ffjeld at common-lisp.net  Tue Jul 13 22:44:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:44:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1BkW0L-0008HT-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Moved the with-simple-restart macro to more-macros.lisp.

Date: Tue Jul 13 15:44:05 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.13 movitz/losp/muerte/more-macros.lisp:1.14
--- movitz/losp/muerte/more-macros.lisp:1.13	Tue Jul 13 07:28:05 2004
+++ movitz/losp/muerte/more-macros.lisp	Tue Jul 13 15:44:05 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.13 2004/07/13 14:28:05 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.14 2004/07/13 22:44:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -315,6 +315,12 @@
 	      :eax)
      (:testb 3 :al)			; Just to be sure..
      (:jnz '(:sub-program () (:int 63)))))
+
+(defmacro with-simple-restart ((name format-control &rest format-arguments)
+					    &body body)
+  `(with-basic-restart (,name 'with-simple-restart nil nil
+			      ,format-control , at format-arguments)
+     , at body))
 
 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 




From ffjeld at common-lisp.net  Tue Jul 13 22:44:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:44:10 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/restarts.lisp 
Message-ID: <E1BkW0Q-0000Ar-00@common-lisp.net>

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

Modified Files:
	restarts.lisp 
Log Message:
Moved the with-simple-restart macro to more-macros.lisp.

Date: Tue Jul 13 15:44:10 2004
Author: ffjeld

Index: movitz/losp/muerte/restarts.lisp
diff -u movitz/losp/muerte/restarts.lisp:1.2 movitz/losp/muerte/restarts.lisp:1.3
--- movitz/losp/muerte/restarts.lisp:1.2	Mon Jan 19 03:23:47 2004
+++ movitz/losp/muerte/restarts.lisp	Tue Jul 13 15:44:10 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct 28 09:27:13 2003
 ;;;;                
-;;;; $Id: restarts.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: restarts.lisp,v 1.3 2004/07/13 22:44:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -198,12 +198,6 @@
 		(restart-format-control restart)
 		(restart-args restart)))))))
   restart)
-
-(defmacro with-simple-restart ((name format-control &rest format-arguments)
-					    &body body)
-  `(with-basic-restart (,name 'with-simple-restart nil nil
-			      ,format-control , at format-arguments)
-     , at body))
 
 ;;;;
 




From ffjeld at common-lisp.net  Tue Jul 13 22:44:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 13 Jul 2004 15:44:37 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BkW0r-0003tk-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Minor edit.

Date: Tue Jul 13 15:44:37 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.17 movitz/losp/muerte/scavenge.lisp:1.18
--- movitz/losp/muerte/scavenge.lisp:1.17	Tue Jul 13 06:00:36 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 13 15:44:37 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.17 2004/07/13 13:00:36 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.18 2004/07/13 22:44:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -150,7 +150,7 @@
 	     (function
 	      (assert (= 0 (funobj-frame-num-unboxed funobj)))
 	      (map-heap-words function (+ nether-frame 2) frame))
-	     ((eql 0)
+	     ((eql 0)			; An interrupt-frame?
 	      ;; 1. Scavenge the interrupt-frame
 	      (map-heap-words function
 			      (+ nether-frame 2)




From ffjeld at common-lisp.net  Wed Jul 14 10:03:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 03:03:45 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bkgc5-0007NJ-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed bogus implementations of abs, signum, max, and min.

Date: Wed Jul 14 03:03:45 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.53 movitz/losp/muerte/integers.lisp:1.54
--- movitz/losp/muerte/integers.lisp:1.53	Tue Jul 13 15:43:40 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 03:03:44 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.53 2004/07/13 22:43:40 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.54 2004/07/14 10:03:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -938,90 +938,59 @@
   `(< ,number 0))
 
 (define-compiler-macro abs (x)
-  `(with-inline-assembly (:returns :eax)
-     (:compile-form (:result-mode :eax) ,x)
-     (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-     (:jnz '(:sub-program () (:int 107)))
-     (:movl :eax :ecx)
-     (:addl :ecx :ecx)
-     (:sbbl :ecx :ecx)
-     (:xorl :ecx :eax)
-     (:subl :ecx :eax)))
+  `(let ((x ,x))
+     (if (>= 0 x) x (- x))))
 
 (defun abs (x)
   (abs x))
 
 (defun signum (x)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) x)
-    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-    (:jnz '(:sub-program (not-fixnum) (:int 107)))
-    (:cdq :eax :edx)
-    (:negl :eax)
-    (:adcl :edx :edx)
-    (:leal ((:edx #.movitz::+movitz-fixnum-factor+)) :eax)))
+  (cond
+   ((> x 0) 1)
+   ((< x 0) -1)
+   (t 0)))
 
 ;;;
 
-(define-compiler-macro max%2op (number1 number2)
-  #+ignore
-  `(let ((number1 ,number1) (number2 ,number2))
-     (if (< number1 number2)
-	 number2 number1))
-  (let ((label (gensym)))
-    `(with-inline-assembly (:returns :eax :type fixnum)
-       (:compile-two-forms (:eax :ebx) ,number1 ,number2)
-       (:movl :ebx :ecx)
-       (:orl :eax :ecx)
-       (:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-       (:jnz '(:sub-program () (:int 107)))
-       (:cmpl :eax :ebx)
-       (:jl ',label)
-       (:movl :ebx :eax)
-       ,label)))
-    
-
-(defun max%2op (number1 number2)
-  (max%2op number1 number2))
-
 (define-compiler-macro max (&whole form first-number &rest more-numbers)
   (case (length more-numbers)
     (0 first-number)
-    (1 `(max%2op ,first-number ,(car more-numbers)))
+    (1 `(let ((x ,first-number)
+	      (y ,(car more-numbers)))
+	  (if (>= x y) x y)))
     ((2 3 4)
-     `(max%2op ,first-number (max , at more-numbers)))
+     `(max ,first-number (max , at more-numbers)))
     (t form)))
 
 (defun max (number1 &rest numbers)
-  (declare (dynamic-extent numbers))
-  (let ((max number1))
-    (dolist (x numbers max)
-      (when (>= x max)
-	(setq max x)))))
-
-(define-compiler-macro min%2op (number1 number2)
-  `(let ((number1 ,number1) (number2 ,number2))
-     (if (< number1 number2)
-	 number1 number2)))
-
-(defun min%2op (number1 number2)
-  (min%2op number1 number2))
+  (numargs-case
+   (2 (x y) (max x y))
+   (t (number1 &rest numbers)
+      (declare (dynamic-extent numbers))
+      (let ((max number1))
+	(dolist (x numbers max)
+	  (when (> x max)
+	    (setq max x)))))))
 
 (define-compiler-macro min (&whole form first-number &rest more-numbers)
   (case (length more-numbers)
     (0 first-number)
-    (1 `(min%2op ,first-number ,(car more-numbers)))
+    (1 `(let ((x ,first-number)
+	      (y ,(car more-numbers)))
+	  (if (<= x y) x y)))
     ((2 3 4)
-     `(min%2op ,first-number (min , at more-numbers)))
+     `(min ,first-number (min , at more-numbers)))
     (t form)))
 
 (defun min (number1 &rest numbers)
-  (declare (dynamic-extent numbers))
-  #+ignore (reduce #'min%2op numbers :initial-value number1)
-  (let ((min number1))
-    (dolist (x numbers min)
-      (when (< x min)
-	(setq min x)))))
+  (numargs-case
+   (2 (x y) (min x y))
+   (t (number1 &rest numbers)
+      (declare (dynamic-extent numbers))
+      (let ((min number1))
+	(dolist (x numbers min)
+	  (when (< x min)
+	    (setq min x)))))))
 
 ;; shift 
 
@@ -1138,10 +1107,11 @@
 	   `(* ,(movitz:movitz-eval factor2 env) ,factor1))
 	  ((movitz:movitz-constantp factor1 env)
 	   (let ((f1 (movitz:movitz-eval factor1 env)))
-	     (check-type f1 fixnum)
+	     (check-type f1 integer)
 	     (case f1
 	       (0 `(progn ,factor2 0))
 	       (1 factor2)
+;;;	       (2 `(let ((x ,factor2)) (+ x x)))
 	       (t `(no-macro-call * ,factor1 ,factor2)))))
 	  (t `(no-macro-call * ,factor1 ,factor2)))))
     (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))
@@ -1564,34 +1534,6 @@
 	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 	       (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))))
     (do-it)))
-
-;;;(define-compiler-macro logbitp (&whole form index integer &environment env)
-;;;  (if (not (movitz:movitz-constantp index env))
-;;;      form
-;;;    (let ((index (movitz::movitz-eval index env)))
-;;;      (check-type index (integer 0 30))
-;;;      `(with-inline-assembly (:returns :boolean-cf=1)
-;;;	 (:compile-form (:result-mode :eax) ,integer)
-;;;	 (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-;;;	 (:jnz '(:sub-program () (:int 107)))
-;;;	 (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax)))))
-
-      
-;;;(defun logand%2op (x y)
-;;;  (with-inline-assembly (:returns :eax)
-;;;    (:compile-form (:result-mode :eax) x)
-;;;    (:compile-form (:result-mode :ebx) y)
-;;;    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-;;;    (:jnz '(:sub-program () (:int 107)))
-;;;    (:testb #.movitz::+movitz-fixnum-zmask+ :bl)
-;;;    (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107)))
-;;;    (:andl :ebx :eax)))
-;;;
-;;;(define-compiler-macro logand%2op (&whole form x y)
-;;;  (cond
-;;;   ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y))
-;;;    (logand  (movitz::movitz-eval x) (movitz::movitz-eval y)))
-;;;   (t form)))
 
 (define-compiler-macro logand (&whole form &rest integers &environment env)
   (let ((constant-folded-integers (loop for x in integers




From ffjeld at common-lisp.net  Wed Jul 14 10:53:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 03:53:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BkhO8-0002Tp-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Fixed a bug in typep for types like (integer * 4).

Date: Wed Jul 14 03:53:24 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.25 movitz/losp/muerte/typep.lisp:1.26
--- movitz/losp/muerte/typep.lisp:1.25	Thu Jul  8 14:50:03 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 14 03:53:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.25 2004/07/08 21:50:03 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.26 2004/07/14 10:53:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -289,7 +289,7 @@
 			   `(typep ,object 'integer))
 			  ((null lower-limit)
 			   `(let ((x ,object))
-			      (and (typep x 'integer) (<= x upper-limit))))
+			      (and (typep x 'integer) (<= x ,upper-limit))))
 			  ((and (null upper-limit)
 				(= (1+ movitz:+movitz-most-positive-fixnum+) lower-limit))
 			   `(with-inline-assembly-case ()




From ffjeld at common-lisp.net  Wed Jul 14 11:01:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 04:01:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkhWB-0000y6-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed a bug in fast-compare-two-reals for negative bignums. Improved
evenp and oddp, and gcd. Removed bogus compiler-macro for ash.

Date: Wed Jul 14 04:01:43 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.54 movitz/losp/muerte/integers.lisp:1.55
--- movitz/losp/muerte/integers.lisp:1.54	Wed Jul 14 03:03:44 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 04:01:43 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.54 2004/07/14 10:03:44 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.55 2004/07/14 11:01:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -41,34 +41,23 @@
 (defun fixnump (x)
   (typep x 'fixnum))
 
-(defun evenp (x)
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :ebx)
-	    (:compile-form (:result-mode :eax) x)
-	    (:movl :eax :ecx)
-	    (:andl 7 :ecx)
-	    (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx))
-	    (:cmpl ,(movitz:tag :even-fixnum) :ecx)
-	    (:je 'done)
-	    (:movl :edi :ebx)
-	    (:cmpl ,(movitz:tag :odd-fixnum) :ecx)
-	    (:je 'done)
-	    (:cmpl ,(movitz:tag :other) :ecx)
-	    (:jnz '(:sub-program (not-integer)
-		    (:int 107)))
-	    (:cmpb ,(movitz:tag :bignum) (:eax ,movitz:+other-type-offset+))
-	    (:jne 'not-integer)
-	    (:testb 1 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-	    (:jnz 'done)
-	    (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx))
-	   done)))
-    (do-it)))
+(define-compiler-macro evenp (x)
+  `(with-inline-assembly (:returns :boolean-zf=1)
+     (:compile-form (:result-mode :eax) ,x)
+     (:call-global-constant unbox-u32)
+     (:testb 1 :cl)))
 
-(defun oddp (x)
-  (not (evenp x)))
+(defun evenp (x)
+  (evenp x))
 
+(define-compiler-macro oddp (x)
+  `(with-inline-assembly (:returns :boolean-zf=0)
+     (:compile-form (:result-mode :eax) ,x)
+     (:call-global-constant unbox-u32)
+     (:testb 1 :cl)))
 
+(defun oddp (x)
+  (oddp x))
 
 ;;; Types
 
@@ -469,6 +458,8 @@
 		 (+ (- subtrahend) minuend))
 		((fixnum bignum)
 		 (- (+ (- minuend) subtrahend)))
+		(((integer 0 *) (integer * -1))
+		 (+ minuend (- subtrahend)))
 		((positive-bignum positive-bignum)
 		 (cond
 		  ((= minuend subtrahend)
@@ -494,8 +485,7 @@
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 			(:jc '(:sub-program (should-not-happen)
 			       (:int 107)))
-			)))))
-		)))
+			))))))))
 	(do-it)))
    (t (minuend &rest subtrahends)
       (declare (dynamic-extent subtrahends))
@@ -571,7 +561,8 @@
 		   (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 	    (:je 'positive-compare-loop)
 	   positive-compare-lsb
-	    ;; Now make the compare unsigned..
+	    ;; Now we have to make the compare act as unsigned, which is why
+	    ;; we compare zero-extended 16-bit quantities.
 	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		     :ecx)		; First compare upper 16 bits.
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
@@ -608,10 +599,22 @@
 	    (:je 'negative-compare-loop)
 	    (:ret)
 	   negative-compare-lsb		; it's down to the LSB bigits.
-	    (:movl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    ;; Now we have to make the compare act as unsigned, which is why
+	    ;; we compare zero-extended 16-bit quantities.
+	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)		; First compare upper 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)
+	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
+	    (:jne 'negative-upper-16-decisive)
+	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
+	   negative-upper-16-decisive
 	    (:ret))))
     (do-it)))
 
@@ -997,13 +1000,15 @@
 (define-compiler-macro ash (&whole form integer count &environment env)
   (if (not (movitz:movitz-constantp count env))
       form
-    (let ((count (movitz::movitz-eval count env)))
+    (let ((count (movitz:movitz-eval count env)))
       (cond
        ((movitz:movitz-constantp integer env)
 	(ash (movitz::movitz-eval integer env) count))
        ((= 0 count)
 	integer)
-       (t (let ((load-integer `((:compile-form (:result-mode :register) ,integer)
+       (t form
+	  #+igore
+	  (let ((load-integer `((:compile-form (:result-mode :register) ,integer)
 				(:testb ,movitz::+movitz-fixnum-zmask+ (:result-register-low8))
 				(:jnz '(:sub-program () (:int 107) (:jmp (:pc+ -4)))))))
 	    (cond
@@ -2267,9 +2272,9 @@
    (2 (u v)
       ;; Code borrowed from CMUCL.
       (do ((k 0 (1+ k))
-	   (u (abs u) (ash u -1))
-	   (v (abs v) (ash v -1)))
-	  ((oddp (logior u v))
+	   (u (abs u) (truncate u 2))
+	   (v (abs v) (truncate v 2)))
+	  ((or (oddp u) (oddp v))
 	   (do ((temp (if (oddp u) (- v) (ash u -1))
 		      (ash temp -1)))
 	       (nil)




From ffjeld at common-lisp.net  Wed Jul 14 12:03:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 05:03:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkiUQ-0002ym-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed bogus abs compiler-macro. Tuned up gcd a bit.

Date: Wed Jul 14 05:03:58 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.55 movitz/losp/muerte/integers.lisp:1.56
--- movitz/losp/muerte/integers.lisp:1.55	Wed Jul 14 04:01:43 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 05:03:58 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.55 2004/07/14 11:01:43 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.56 2004/07/14 12:03:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -942,7 +942,7 @@
 
 (define-compiler-macro abs (x)
   `(let ((x ,x))
-     (if (>= 0 x) x (- x))))
+     (if (>= x 0) x (- x))))
 
 (defun abs (x)
   (abs x))
@@ -1427,7 +1427,14 @@
 		       (setf q (1+ q)
 			     r (- r divisor))
 		     (setf q (+ q guess)
-			   r (- r (* divisor guess))))))))))))))
+			   r (- r (* divisor guess))))))))))
+	(((integer * -1) (integer 0 *))
+	 (- (truncate (- number) divisor)))
+	(((integer 0 *) (integer * -1))
+	 (- (truncate number (- divisor))))
+	(((integer * -1) (integer * -1))
+	 (truncate (- number) (- divisor)))
+	))))
 
 (defun / (number &rest denominators)
   (declare (dynamic-extent denominators))
@@ -2275,20 +2282,18 @@
 	   (u (abs u) (truncate u 2))
 	   (v (abs v) (truncate v 2)))
 	  ((or (oddp u) (oddp v))
-	   (do ((temp (if (oddp u) (- v) (ash u -1))
-		      (ash temp -1)))
+	   (do ((temp (if (oddp u)
+			  (- v)
+			(truncate u 2))
+		      (truncate temp 2)))
 	       (nil)
-	     (declare (fixnum temp))
 	     (when (oddp temp)
 	       (if (plusp temp)
 		   (setq u temp)
 		 (setq v (- temp)))
 	       (setq temp (- u v))
 	       (when (zerop temp)
-		 (let ((res (ash u k)))
-		   (declare (type (signed-byte 31) res)
-			    (optimize (inhibit-warnings 3)))
-		   (return res))))))))
+		 (return (ash u k))))))))
    (t (&rest numbers)
       (declare (dynamic-extent numbers))
       (do ((gcd (car numbers)




From ffjeld at common-lisp.net  Wed Jul 14 12:16:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 05:16:28 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkigW-0001cf-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed - for negative bignums.

Date: Wed Jul 14 05:16:28 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.56 movitz/losp/muerte/integers.lisp:1.57
--- movitz/losp/muerte/integers.lisp:1.56	Wed Jul 14 05:03:58 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 05:16:28 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.56 2004/07/14 12:03:58 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.57 2004/07/14 12:16:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -454,12 +454,10 @@
 		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
 		   (:subl :ebx :eax)
 		   (:into)))
-		((bignum fixnum)
+		((positive-bignum fixnum)
 		 (+ (- subtrahend) minuend))
-		((fixnum bignum)
+		((fixnum positive-bignum)
 		 (- (+ (- minuend) subtrahend)))
-		(((integer 0 *) (integer * -1))
-		 (+ minuend (- subtrahend)))
 		((positive-bignum positive-bignum)
 		 (cond
 		  ((= minuend subtrahend)
@@ -485,7 +483,14 @@
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 			(:jc '(:sub-program (should-not-happen)
 			       (:int 107)))
-			))))))))
+			)))))
+		(((integer 0 *) (integer * -1))
+		 (+ minuend (- subtrahend)))
+		(((integer * -1) (integer 0 *))
+		 (- (+ (- minuend) subtrahend)))
+		(((integer * -1) (integer * -1))
+		 (+ minuend (- subtrahend)))
+		)))
 	(do-it)))
    (t (minuend &rest subtrahends)
       (declare (dynamic-extent subtrahends))




From ffjeld at common-lisp.net  Wed Jul 14 12:28:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 05:28:06 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bkirm-0004zt-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Remember to return the remainder also, when implementing truncate on
negatives in terms of truncate on positives.

Date: Wed Jul 14 05:28:06 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.57 movitz/losp/muerte/integers.lisp:1.58
--- movitz/losp/muerte/integers.lisp:1.57	Wed Jul 14 05:16:28 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 05:28:06 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.57 2004/07/14 12:16:28 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.58 2004/07/14 12:28:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1434,11 +1434,17 @@
 		     (setf q (+ q guess)
 			   r (- r (* divisor guess))))))))))
 	(((integer * -1) (integer 0 *))
-	 (- (truncate (- number) divisor)))
+	 (multiple-value-bind (q r)
+	     (truncate (- number) divisor)
+	   (values (- q) (- r))))
 	(((integer 0 *) (integer * -1))
-	 (- (truncate number (- divisor))))
+	 (multiple-value-bind (q r)
+	     (truncate (- number) divisor)
+	   (values (- q) r)))
 	(((integer * -1) (integer * -1))
-	 (truncate (- number) (- divisor)))
+	 (multiple-value-bind (q r)
+	     (truncate (- number) divisor)
+	   (values q (- r))))
 	))))
 
 (defun / (number &rest denominators)




From ffjeld at common-lisp.net  Wed Jul 14 12:36:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 05:36:50 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bkj0E-0005O4-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Implemented + on negatives in terms of -.

Date: Wed Jul 14 05:36:50 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.58 movitz/losp/muerte/integers.lisp:1.59
--- movitz/losp/muerte/integers.lisp:1.58	Wed Jul 14 05:28:06 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 05:36:50 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.58 2004/07/14 12:28:06 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.59 2004/07/14 12:36:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -362,6 +362,12 @@
 		   
 		    pfix-pbig-done)
 		   ))
+		(((integer * -1) (integer 0 *))
+		 (- y (- x)))
+		(((integer 0 *) (integer * -1))
+		 (- x (- y)))
+		(((integer * -1) (integer * -1))
+		 (+ (- x) (- y)))
 		)))
 	(do-it)))
    (t (&rest terms)




From ffjeld at common-lisp.net  Wed Jul 14 13:48:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 06:48:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bkk7I-00024n-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed a bug in integer-length on bignums.

Date: Wed Jul 14 06:48:12 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.59 movitz/losp/muerte/integers.lisp:1.60
--- movitz/losp/muerte/integers.lisp:1.59	Wed Jul 14 05:36:50 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 06:48:11 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.59 2004/07/14 12:36:50 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.60 2004/07/14 13:48:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1098,7 +1098,7 @@
 			:ecx)
 	       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
 		      :eax)		; bigits-1
-	       (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	       (:bsrl (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 		      :ecx)
 	       (:shll 5 :eax)		; bits = bigits*32 + (bit-index+1)
 	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax




From ffjeld at common-lisp.net  Wed Jul 14 13:53:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 06:53:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkkCC-0005OT-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
In ceiling, calculate correct remainder.

Date: Wed Jul 14 06:53:16 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.60 movitz/losp/muerte/integers.lisp:1.61
--- movitz/losp/muerte/integers.lisp:1.60	Wed Jul 14 06:48:11 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 06:53:16 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.60 2004/07/14 13:48:11 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.61 2004/07/14 13:53:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1509,7 +1509,9 @@
 (defun ceiling (number &optional (divisor 1))
   (case (+ (if (minusp number) #b10 0)
 	   (if (minusp divisor) #b01 0))
-    (#b00 (truncate (+ number divisor -1) divisor))
+    (#b00 (multiple-value-bind (q r)
+	      (truncate (+ number divisor -1) divisor)
+	    (values q (- r (1- divisor)))))
     (t (error "Don't know."))))
 
 (defun rem (dividend divisor)




From ffjeld at common-lisp.net  Wed Jul 14 16:17:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 09:17:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkmSE-0007wu-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed a braino in bignum addition; sometimes carry wasn't propagated
right. I'll have to do the same fix to -.

Date: Wed Jul 14 09:17:58 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.61 movitz/losp/muerte/integers.lisp:1.62
--- movitz/losp/muerte/integers.lisp:1.61	Wed Jul 14 06:53:16 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 09:17:57 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.61 2004/07/14 13:53:16 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.62 2004/07/14 16:17:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -283,7 +283,6 @@
 		   ;; Assume x is smallest.
 		   (with-inline-assembly (:returns :eax :labels (retry-not-size1
 								 not-size1
-								 term-zero
 								 copy-bignum-loop
 								 add-bignum-loop
 								 add-bignum-done
@@ -339,8 +338,14 @@
 			     (:jmp 'add-bignum-done)))
 		     (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 			    :ecx)
-		    term-zero
-		     (:adcl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:jc '(:sub-program (term1-carry)
+			    ;; The digit + carry carried over, ECX = 0
+			    (:movl 1 :ecx)
+			    (:addl 4 :edx)
+			    (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			    (:jae 'add-bignum-loop)
+			    (:jmp 'add-bignum-done)))
+		     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 		     (:sbbl :ecx :ecx)
 		     (:negl :ecx)	; ECX = Add's Carry.
 		     (:addl 4 :edx)
@@ -478,7 +483,10 @@
 		       sub-loop
 			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 			       :ecx)
-			(:sbbl :ecx
+			(:jc '(:sub-program (carry-overflow)
+			       ;;
+			       (:break)))
+			(:subl :ecx
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 			(:sbbl :ecx :ecx)
 			(:negl :ecx)
@@ -1287,8 +1295,8 @@
 		   ;; X is the biggest factor.
 		   (let ((r 0) (f 0))
 		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
-		       (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
-				    f))
+		       (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
+					  f)))
 		       (incf f 16))
 		     r))))))
 	(do-it)))




From ffjeld at common-lisp.net  Wed Jul 14 21:58:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 14:58:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BkrmE-0002r3-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed carry-propagation for -.

Date: Wed Jul 14 14:58:58 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.62 movitz/losp/muerte/integers.lisp:1.63
--- movitz/losp/muerte/integers.lisp:1.62	Wed Jul 14 09:17:57 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 14:58:58 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.62 2004/07/14 16:17:57 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.63 2004/07/14 21:58:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -340,7 +340,7 @@
 			    :ecx)
 		     (:jc '(:sub-program (term1-carry)
 			    ;; The digit + carry carried over, ECX = 0
-			    (:movl 1 :ecx)
+			    (:addl 1 :ecx)
 			    (:addl 4 :edx)
 			    (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
 			    (:jae 'add-bignum-loop)
@@ -474,7 +474,12 @@
 		  ((= minuend subtrahend)
 		   0)
 		  ((< minuend subtrahend)
-		   (- (- subtrahend minuend)))
+		   (let ((x (- subtrahend minuend)))
+		     (when (typep x 'bignum)
+		       (setf (memref x ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)
+				     0 :unsigned-byte8)
+			 #xff))
+		     x))
 		  (t (%bignum-canonicalize
 		      (with-inline-assembly (:returns :eax)
 			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
@@ -484,8 +489,12 @@
 			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
 			       :ecx)
 			(:jc '(:sub-program (carry-overflow)
-			       ;;
-			       (:break)))
+			       ;; Just propagate carry
+			       (:addl 1 :ecx)
+			       (:addl 4 :edx)
+			       (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			       (:jne 'sub-loop)
+			       (:jmp 'bignum-sub-done)))
 			(:subl :ecx
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 			(:sbbl :ecx :ecx)
@@ -497,6 +506,7 @@
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
 			(:jc '(:sub-program (should-not-happen)
 			       (:int 107)))
+		       bignum-sub-done
 			)))))
 		(((integer 0 *) (integer * -1))
 		 (+ minuend (- subtrahend)))




From ffjeld at common-lisp.net  Wed Jul 14 23:45:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 16:45:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BktR2-0003Hs-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Speeded up bignum truncate.

Date: Wed Jul 14 16:45:12 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.63 movitz/losp/muerte/integers.lisp:1.64
--- movitz/losp/muerte/integers.lisp:1.63	Wed Jul 14 14:58:58 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 16:45:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.63 2004/07/14 21:58:58 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.64 2004/07/14 23:45:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1440,23 +1440,32 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (let* ((msb-pos (1- (* 2 (%bignum-bigits divisor))))
-		    (msb (memref divisor -2 msb-pos :unsigned-byte16)))
-	       (when (= 0 msb)
+	  (t (let* ((msb-pos (1- (* 4 (%bignum-bigits divisor))))
+		    (msb (memref divisor -2 msb-pos :unsigned-byte8)))
+	       (do () ((not (eq 0 msb)))
 		 (decf msb-pos)
-		 (setf msb (memref divisor -2 msb-pos :unsigned-byte16))
-		 (assert (plusp msb)))
-	       (do ((msb+1 (1+ msb))
-		    (q 0) (r number))
-		   ((< r divisor) (values q r))
-		 (let ((guess (truncate r msb+1)))
-		   (dotimes (i msb-pos)
-		     (setf guess (truncate guess #x10000)))
-		   (if (= 0 guess)
-		       (setf q (1+ q)
-			     r (- r divisor))
-		     (setf q (+ q guess)
-			   r (- r (* divisor guess))))))))))
+		 (setf msb (memref divisor -2 msb-pos :unsigned-byte8)))
+	       (decf msb-pos 2)
+	       (setf msb (+ (* #x10000 msb)
+			    (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8))
+			    (memref divisor -2 msb-pos :unsigned-byte8)))
+	       (multiple-value-bind (long-shift short-shift)
+		   ;; This shifting stuff should be replaced by ash,
+		   ;; when ash is properly implemented.
+		   (truncate msb-pos 3)
+		 (do ((msb+1 (1+ msb))
+		      (q 0) (r number))
+		     ((< r divisor) (values q r))
+		   (let ((guess (truncate r msb+1)))
+		     (dotimes (i long-shift)
+		       (setf guess (truncate guess #x1000000)))
+		     (dotimes (i short-shift)
+		       (setf guess (truncate guess #x100)))
+		     (if (= 0 guess)
+			 (setf q (1+ q)
+			       r (- r divisor))
+		       (setf q (+ q guess)
+			     r (- r (* divisor guess)))))))))))
 	(((integer * -1) (integer 0 *))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)




From ffjeld at common-lisp.net  Thu Jul 15 00:26:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:26:26 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bku4w-0003JR-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added %negatef, in an effort to reduce bignum consing a bit.

Date: Wed Jul 14 17:26:26 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.64 movitz/losp/muerte/integers.lisp:1.65
--- movitz/losp/muerte/integers.lisp:1.64	Wed Jul 14 16:45:12 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 14 17:26:26 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.64 2004/07/14 23:45:12 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.65 2004/07/15 00:26:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -87,6 +87,19 @@
 (define-simple-typep (bit bitp) (x)
   (or (eq x 0) (eq x 1)))
 
+;;; 
+
+(defun %negatef (x p0 p1)
+  "Negate x. If x is not eq to p0 or p1, negate x destructively."
+  (etypecase x
+    (fixnum (- x))
+    (bignum
+     (if (or (eq x p0) (eq x p1))
+	 (- x)
+       (with-inline-assembly (:returns :eax)
+	 (:compile-form (:result-mode :eax) x)
+	 (:xorl #xff00 (:eax #.movitz:+other-type-offset+)))))))
+
 ;;; Addition
 
 (define-compiler-macro + (&whole form &rest operands &environment env)
@@ -364,7 +377,6 @@
 		     (:call-global-constant cons-commit)
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))
-		   
 		    pfix-pbig-done)
 		   ))
 		(((integer * -1) (integer 0 *))
@@ -372,7 +384,7 @@
 		(((integer 0 *) (integer * -1))
 		 (- x (- y)))
 		(((integer * -1) (integer * -1))
-		 (+ (- x) (- y)))
+		 (%negatef (+ (- x) (- y)) x y))
 		)))
 	(do-it)))
    (t (&rest terms)
@@ -511,7 +523,7 @@
 		(((integer 0 *) (integer * -1))
 		 (+ minuend (- subtrahend)))
 		(((integer * -1) (integer 0 *))
-		 (- (+ (- minuend) subtrahend)))
+		 (%negatef (+ (- minuend) subtrahend) minuend subtrahend))
 		(((integer * -1) (integer * -1))
 		 (+ minuend (- subtrahend)))
 		)))
@@ -520,7 +532,7 @@
       (declare (dynamic-extent subtrahends))
       (if subtrahends
 	  (reduce #'- subtrahends :initial-value minuend)
-	(- 0 minuend)))))
+	(- minuend)))))
     
 (define-modify-macro decf (&optional (delta-form 1)) -)
 
@@ -1469,15 +1481,17 @@
 	(((integer * -1) (integer 0 *))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)
-	   (values (- q) (- r))))
+	   (values (%negatef q number divisor)
+		   (%negatef r number divisor))))
 	(((integer 0 *) (integer * -1))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)
-	   (values (- q) r)))
+	   (values (%negatef q number divisor)
+		   r)))
 	(((integer * -1) (integer * -1))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)
-	   (values q (- r))))
+	   (values q (%negatef r number divisor))))
 	))))
 
 (defun / (number &rest denominators)




From ffjeld at common-lisp.net  Thu Jul 15 00:27:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:27:13 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bku5h-0005M8-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Some tweaking of GC messages etc.

Date: Wed Jul 14 17:27:13 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.25 movitz/losp/los0-gc.lisp:1.26
--- movitz/losp/los0-gc.lisp:1.25	Tue Jul 13 06:02:45 2004
+++ movitz/losp/los0-gc.lisp	Wed Jul 14 17:27:13 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.25 2004/07/13 13:02:45 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.26 2004/07/15 00:27:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,14 +18,14 @@
 
 (in-package muerte.init)
 
-(defconstant +space-size+ #xfffd)
-
-(defun make-space (location)
+(defvar *gc-quiet* nil)
+    
+(defun make-space (location size)
   "Make a space vector at a fixed location."
   (assert (evenp location))
   (macrolet ((x (index)
 	       `(memref location 0 ,index :unsigned-byte32)))
-    (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ +space-size+)
+    (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size)
 	  (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
 			  (cl:byte 8 8)
 			  (bt:enum-value 'movitz:other-type-byte :basic-vector))))
@@ -247,12 +247,16 @@
     (setf (exception-handler 113)
       (lambda (exception interrupt-frame)
 	(declare (ignore exception interrupt-frame))
-	(format t "~&;; GC.. ")
+	(unless *gc-quiet*
+	  (format t "~&;; GC.. "))
 	(stop-and-copy)
 	;; This is  a nice opportunity to poll the keyboard..
-	(case (muerte.x86-pc.keyboard:poll-char)
-	  ((#\esc)
-	   (break "Los0 GC keyboard poll.")))))
+	(loop
+	  (case (muerte.x86-pc.keyboard:poll-char)
+	    ((#\esc)
+	     (break "Los0 GC keyboard poll."))
+	    ((nil)
+	     (return))))))
     (let ((conser (symbol-value 'los0-fast-cons)))
       (check-type conser vector)
       (setf (%run-time-context-slot 'muerte::fast-cons)
@@ -406,10 +410,11 @@
 	      "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace)))
 
 	;; GC completed, oldspace is evacuated.
-	(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
-	      (new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))
-	  (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
+	(unless *gc-quiet*
+	  (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
+		(new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))
+	    (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
-		  old-size new-size (- old-size new-size)))
+		    old-size new-size (- old-size new-size))))
 	(initialize-space oldspace))))
   (values))




From ffjeld at common-lisp.net  Thu Jul 15 00:27:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:27:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1Bku62-0007XJ-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Minor edit.

Date: Wed Jul 14 17:27:34 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.18 movitz/losp/muerte/scavenge.lisp:1.19
--- movitz/losp/muerte/scavenge.lisp:1.18	Tue Jul 13 15:44:37 2004
+++ movitz/losp/muerte/scavenge.lisp	Wed Jul 14 17:27:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.18 2004/07/13 22:44:37 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.19 2004/07/15 00:27:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -181,7 +181,7 @@
 			  (map-heap-words function (1+ interrupted-esp) frame)
 			(error "Don't know how to scavenge across interrupt frame at ~S."
 			       interrupt-frame)))))))
-	     (t (error "Don't know how to scavenge across a frame of kind ~S." funobj)))))
+	     (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))
   (values))
 
 (defparameter *primitive-funcall-patterns*




From ffjeld at common-lisp.net  Thu Jul 15 00:28:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:28:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1Bku6w-0002Xy-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv9312

Modified Files:
	debugger.lisp 
Log Message:
Have the debugger accept bigger pointer-sizes as "reasonable".

Date: Wed Jul 14 17:28:30 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.15 movitz/losp/x86-pc/debugger.lisp:1.16
--- movitz/losp/x86-pc/debugger.lisp:1.15	Mon Jul 12 04:10:40 2004
+++ movitz/losp/x86-pc/debugger.lisp	Wed Jul 14 17:28:30 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.15 2004/07/12 11:10:40 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.16 2004/07/15 00:28:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -58,8 +58,7 @@
 (defun pointer-in-range (x)
   (with-inline-assembly (:returns :boolean-cf=1)
     (:compile-form (:result-mode :eax) x)
-    ;; (:subl #x100000 :eax)
-    (:cmpl #x1000000 :eax)))
+    (:cmpl #x10000000 :eax)))
 
     
 (defun code-vector-offset (code-vector address)




From ffjeld at common-lisp.net  Thu Jul 15 00:29:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:29:19 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1Bku7j-0005U8-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Removed dead code.

Date: Wed Jul 14 17:29:19 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.26 movitz/special-operators.lisp:1.27
--- movitz/special-operators.lisp:1.26	Mon Jul 12 19:26:14 2004
+++ movitz/special-operators.lisp	Wed Jul 14 17:29:19 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.26 2004/07/13 02:26:14 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.27 2004/07/15 00:29:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1012,120 +1012,6 @@
       (compiler-values ()
 	:returns returns
 	:code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns))))))
-    
-
-(define-special-operator muerte::+%2op (&all all &form form &env env &result-mode result-mode)
-  (assert (not (eq :boolean result-mode)) ()
-    "Boolean result-mode for +%2op makes no sense.")
-  (destructuring-bind (term1 term2)
-      (cdr form)
-    (flet ((compile-constant-add (constant-term term-form)
-	     (compiler-values-bind (&code term2-code &returns term2-returns &type term2-type
-				    &functional-p term2-functional-p &modifies term2-modifies)
-		 (compiler-call #'compile-form-unprotected
-		   :result-mode (case result-mode
-				  ((:eax :ebx :ecx :edx)
-				   result-mode)
-				  (t :eax))
-		   :defaults all
-		   :form term-form)
-	       (assert term2-type)
-	       (let ((term2-type (type-specifier-primary term2-type)))
-;;;		 (declare (ignore term2-type))
-;;;		 (warn "t2-type: ~S, t2-ret: ~S, rm: ~S"
-;;;		       term2-type term2-returns result-mode)
-		 (cond
-		  ((and (eq 'binding-type (operator term2-type))
-			(eq (second term2-type) result-mode))
-		   (let ((binding result-mode))
-		     (check-type binding lexical-binding)
-		     (compiler-values ()
-		       :returns binding
-		       :type (binding-type-specifier binding)
-		       :code (append
-			      (compiler-call #'compile-form-unprotected
-				:result-mode :ignore
-				:defaults all
-				:form term-form)
-			      `((:incf-lexvar ,binding ,constant-term))))))
-		  ((eq :untagged-fixnum-eax term2-returns)
-		   (case result-mode
-		     (:untagged-fixnum-eax
-		      (compiler-values ()
-			:returns :untagged-fixnum-eax
-			:type 'integer
-			:functional-p term2-functional-p
-			:modifies term2-modifies
-			:code (append term2-code
-				      `((:addl ,constant-term :eax))
-				      (unless (< #x-10000 constant-term #x10000)
-					'((:into))))))
-		     (t (let ((result-register (accept-register-mode result-mode)))
-			  ;; (warn "XX")
-			  (compiler-values ()
-			    :returns result-register
-			    :modifies term2-modifies
-			    :functional-p term2-functional-p
-			    :code (append term2-code
-					  `((:leal ((:eax ,+movitz-fixnum-factor+)
-						    ,(* +movitz-fixnum-factor+ constant-term))
-						   ,result-register))))))))
-		  (t (multiple-value-bind (new-load-term-code add-result-mode)
-			 (make-result-and-returns-glue (accept-register-mode term2-returns)
-						       term2-returns
-						       term2-code)
-		       (let ((add-register (single-value-register add-result-mode))
-			     (label (gensym "not-integer-")))
-			 (compiler-values ()
-			   :returns add-register
-			   :functional-p term2-functional-p
-			   :modifies term2-modifies
-			   :type 'integer
-			   :code (append
-				  new-load-term-code
-				  (unless nil
-				    #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
-						       `(integer ,+movitz-most-negative-fixnum+
-								 ,+movitz-most-positive-fixnum+))
-				    `((:testb ,+movitz-fixnum-zmask+
-					      ,(register32-to-low8 add-register))
-				      (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4))))))
-				  `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register))
-				  (unless nil
-				    #+ignore (subtypep (translate-program term2-type :muerte.cl :cl)
-						       `(integer ,(+ +movitz-most-negative-fixnum+
-								     constant-term)
-								 ,(+ +movitz-most-positive-fixnum+
-								     constant-term)))
-				    '((:into)))))))))))))
-      (cond
-       ((and (movitz-constantp term1 env)
-	     (movitz-constantp term2 env))
-	(compiler-call #'compile-self-evaluating
-	  :forward all
-	  :form (+ (eval-form term1 env)
-		   (eval-form term2 env))))
-       ((and (movitz-constantp term1 env) ; first operand zero?
-	     (zerop (eval-form term1 env)))
-	(compiler-call #'compile-form-unprotected
-	  :forward all
-	  :form term2))			; (+ 0 x) => x
-       ((and (movitz-constantp term2 env)	; second operand zero?
-	     (zerop (eval-form term2 env)))
-	(compiler-call #'compile-form-unprotected
-	  :forward all
-	  :form term1))			; (+ x 0) => x
-       ((movitz-constantp term1 env)
-	(let ((constant-term1 (eval-form term1 env)))
-	  (check-type constant-term1 (signed-byte 30))
-	  (compile-constant-add constant-term1 term2)))
-       ((movitz-constantp term2 env)
-	(let ((constant-term2 (eval-form term2 env)))
-	  (check-type constant-term2 (signed-byte 30))
-	  (compile-constant-add constant-term2 term1)))
-       (t (compiler-call #'compile-apply-symbol
-	    :forward all
-	    :form `(muerte.cl:+ ,term1 ,term2)))))))
 
 (define-special-operator muerte::include (&form form)
   (let ((*require-dependency-chain*




From ffjeld at common-lisp.net  Thu Jul 15 00:29:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 14 Jul 2004 17:29:39 -0700
Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt 
Message-ID: <E1Bku83-0006Ao-00@common-lisp.net>

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

Modified Files:
	bochsrc.txt 
Log Message:
Added keyboard_mapping config line.

Date: Wed Jul 14 17:29:39 2004
Author: ffjeld

Index: movitz/bochsrc.txt
diff -u movitz/bochsrc.txt:1.3 movitz/bochsrc.txt:1.4
--- movitz/bochsrc.txt:1.3	Tue Jul 13 06:00:10 2004
+++ movitz/bochsrc.txt	Wed Jul 14 17:29:39 2004
@@ -18,6 +18,9 @@
 #diskc: file=hd10meg.img, cyl=306, heads=4, spt=17
 #newharddrivesupport: enabled=1
 
+# This is just to make X11 clipboard pasting into bochs work.
+keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map
+
 # choose the boot disk.
 boot: a
 




From ffjeld at common-lisp.net  Thu Jul 15 11:16:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 04:16:14 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1Bl4Dm-0003K7-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added a symbol to muerte.

Date: Thu Jul 15 04:16:14 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.30 movitz/packages.lisp:1.31
--- movitz/packages.lisp:1.30	Sun Jul 11 15:59:26 2004
+++ movitz/packages.lisp	Thu Jul 15 04:16:14 2004
@@ -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.30 2004/07/11 22:59:26 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.31 2004/07/15 11:16:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1189,6 +1189,7 @@
 	   map-active-restarts
 	   with-basic-restart
 
+	   #:code-vector
 	   #:vector-u8
 	   #:vector-u16
 	   #:vector-u32




From ffjeld at common-lisp.net  Thu Jul 15 11:17:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 04:17:03 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1Bl4EZ-0004Mp-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Fixed bug in (setf %run-time-context-slot) for slots of type code-vector-word.

Date: Thu Jul 15 04:17:02 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.7 movitz/losp/muerte/run-time-context.lisp:1.8
--- movitz/losp/muerte/run-time-context.lisp:1.7	Thu Jul  8 11:53:57 2004
+++ movitz/losp/muerte/run-time-context.lisp	Thu Jul 15 04:17:02 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.7 2004/07/08 18:53:57 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.8 2004/07/15 11:17:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -90,7 +90,7 @@
       (lu32
        (setf (memref context -6 (third slot) :unsigned-byte32) value))
       (code-vector-word
-       (setf (memref context -6 (third slot) :unsigned-byte32) value)))))
+       (setf (memref context -6 (third slot) :code-vector) value)))))
 
 (defun %run-time-context-segment-base (slot-name
 				      &optional (context (current-run-time-context)))




From ffjeld at common-lisp.net  Thu Jul 15 11:18:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 04:18:49 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1Bl4GH-0006gj-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
For the default, 'dummy' GC architecture, provide some operators that
were missing before (ie. only implemented in los0-gc) so that
e.g. bignum-consing will work without los0-gc.

Date: Thu Jul 15 04:18:49 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.27 movitz/losp/muerte/primitive-functions.lisp:1.28
--- movitz/losp/muerte/primitive-functions.lisp:1.27	Mon Jul 12 19:26:28 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Jul 15 04:18:49 2004
@@ -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.27 2004/07/13 02:26:28 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.28 2004/07/15 11:18:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -443,6 +443,48 @@
     (:leal (:eax :ecx) :eax)
     (:ret)))
 
+(define-primitive-function muerte::get-cons-pointer ()
+  "Return in EAX the next object location with space for EAX words, with tag 6.
+Preserve ECX."
+  (macrolet
+      ((do-it ()
+	 ;; Here we just call malloc, and don't care if the allocation
+	 ;; is never comitted.
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movl :eax :ebx)
+	    (:call-global-constant malloc)
+	    (:locally (:movl (:edi (:edi-offset scratch0)) :ecx))
+	    (:leal (:eax 6) :eax)
+	    (:ret))
+	 #+ignore
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
+	    (:movl (:eax 4) :ecx)	; cons pointer to ECX
+	    (:leal (:eax :ecx 6) :eax)
+	    (:ret))))
+    (do-it)))
+
+(define-primitive-function muerte::cons-commit ()
+  "Commit allocation of ECX/fixnum words.
+Preserve EAX and EBX."
+  (macrolet
+      ((do-it ()
+	 ;; Since get-cons-pointer is implemented as an (already committed)
+	 ;; malloc, this is a NOP
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:ret))
+	 #+ignore
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:pushl :eax)
+	    (:pushl :ebx)
+	    (:movl :ecx :ebx)
+	    (:call-global-constant malloc)
+	    (:popl :ebx)
+	    (:popl :eax)
+	    (:ret))))
+    (do-it)))
+
 (defun malloc-initialize (buffer-start buffer-size)
   "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units."
   (check-type buffer-start fixnum)
@@ -494,7 +536,7 @@
     (:leal (:eax :edx) :eax)
     (:movl :ecx (:eax))
     (:movl :ebx (:eax 4))
-    (:incl :eax)
+    (:addl 1 :eax)
     (:ret)))
 
 (define-primitive-function ensure-heap-cons-variable ()
@@ -517,16 +559,28 @@
     return-ok
     (:ret)))
 
-
 (define-primitive-function box-u32-ecx ()
   "Make u32 in ECX into a fixnum or bignum in EAX."
-  (with-inline-assembly (:returns :multiple-values)
-    (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx)
-    (:ja 'not-fixnum)
-    (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax)
-    (:ret)
-   not-fixnum
-    (:int 107)))			; not implemented by default!
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx)
+	    (:ja 'not-fixnum)
+	    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+	    (:ret)
+	   not-fixnum
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) ; Save value for later
+	    (:call-global-constant malloc)
+	    (:movl ,(dpb movitz:+movitz-fixnum-factor+
+			 (byte 16 16)
+			 (movitz:tag :bignum 0))
+		   (:eax))
+	    (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) ; Restore value
+	    (:movl :ecx (:eax 4))
+	    (:leal (:eax 6) :eax)
+	    (:ret))))
+    (do-it)))
+	    
 
 (define-primitive-function unbox-u32 ()
   "Load (ldb (byte 32 0) EAX) into ECX."
@@ -550,6 +604,8 @@
 	   fail
 	    (:int 107))))
     (do-it)))
+
+	    
 
 ;;;;
 




From ffjeld at common-lisp.net  Thu Jul 15 11:22:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 04:22:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bl4JU-00084e-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Some pieces of los0-gc were (because of laziness) set up as part of
the default system. This factors out los0-gc from the default system
properly. Also, changed the signature and implementation of
install-los0-consing a bit: It now takes the run-time-context object
to install onto as an explicit (keyword) argument.

Date: Thu Jul 15 04:22:08 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.26 movitz/losp/los0-gc.lisp:1.27
--- movitz/losp/los0-gc.lisp:1.26	Wed Jul 14 17:27:13 2004
+++ movitz/losp/los0-gc.lisp	Thu Jul 15 04:22:08 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.26 2004/07/15 00:27:13 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.27 2004/07/15 11:22:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -99,7 +99,7 @@
 	    (:ret))))
     (do-it)))
 
-(define-primitive-function muerte::get-cons-pointer ()
+(define-primitive-function los0-get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
   (macrolet
@@ -123,7 +123,7 @@
 	    (:ret))))
     (do-it)))
 
-(define-primitive-function muerte::cons-commit ()
+(define-primitive-function los0-cons-commit ()
   "Commit allocation of ECX/fixnum words.
 Preserve EAX and EBX."
   (macrolet
@@ -240,42 +240,44 @@
 	    (:leal (:edx :ecx 8) :eax))))
     (do-it)))
 
-(defun install-los0-consing (&optional (space-kilobytes 1024))
-  (let ((size (* space-kilobytes #x100)))
-    (setf (%run-time-context-slot 'nursery-space)
-      (allocate-duo-space size))
-    (setf (exception-handler 113)
-      (lambda (exception interrupt-frame)
-	(declare (ignore exception interrupt-frame))
-	(unless *gc-quiet*
-	  (format t "~&;; GC.. "))
-	(stop-and-copy)
-	;; This is  a nice opportunity to poll the keyboard..
-	(loop
-	  (case (muerte.x86-pc.keyboard:poll-char)
-	    ((#\esc)
-	     (break "Los0 GC keyboard poll."))
-	    ((nil)
-	     (return))))))
-    (let ((conser (symbol-value 'los0-fast-cons)))
-      (check-type conser vector)
-      (setf (%run-time-context-slot 'muerte::fast-cons)
-	conser))
-    (let ((conser (symbol-value 'los0-box-u32-ecx)))
-      (check-type conser vector)
-      (setf (%run-time-context-slot 'muerte::box-u32-ecx)
-	conser))
-    (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
-      (setf (symbol-function 'muerte:malloc-clumps)
-	(symbol-function 'los0-malloc-clumps))
-      (setf (symbol-function 'los0-malloc-clumps)
-	old-malloc))
-    (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
-      (setf (symbol-function 'muerte:malloc-data-clumps)
-	(symbol-function 'los0-malloc-data-clumps))
-      (setf (symbol-function 'los0-malloc-data-clumps)
-	old-malloc-data))
-    (values)))
+(defun install-los0-consing (&key (run-time-context (current-run-time-context))
+				  (kb-size 1024)
+				  duo-space)
+  "Install the 'Los0' GC architecture on run-time-context."
+  (setf (%run-time-context-slot 'nursery-space run-time-context)
+    (or duo-space
+	(allocate-duo-space (* kb-size #x100))))
+  (setf (exception-handler 113)
+    (lambda (exception interrupt-frame)
+      (declare (ignore exception interrupt-frame))
+      (unless *gc-quiet*
+	(format t "~&;; GC.. "))
+      (stop-and-copy)
+      (loop				; This is  a nice opportunity to poll the keyboard..
+	(case (muerte.x86-pc.keyboard:poll-char)
+	  ((#\esc)
+	   (break "Los0 GC keyboard poll."))
+	  ((nil)
+	   (return))))))
+  (flet ((install-primitive (name slot)
+	   (let ((code-vector (symbol-value name)))
+	     (check-type code-vector code-vector)
+	     (setf (%run-time-context-slot slot run-time-context) code-vector))))
+    (install-primitive 'los0-fast-cons 'muerte::fast-cons)
+    (install-primitive 'los0-box-u32-ecx 'muerte::box-u32-ecx)
+    (install-primitive 'los0-get-cons-pointer 'muerte::get-cons-pointer)
+    (install-primitive 'los0-cons-commit 'muerte::cons-commit))
+  (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
+    (setf (symbol-function 'muerte:malloc-clumps)
+      (symbol-function 'los0-malloc-clumps))
+    (setf (symbol-function 'los0-malloc-clumps)
+      old-malloc))
+  (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
+    (setf (symbol-function 'muerte:malloc-data-clumps)
+      (symbol-function 'los0-malloc-data-clumps))
+    (setf (symbol-function 'los0-malloc-data-clumps)
+      old-malloc-data))
+  (values))
 
 (defun install-old-consing ()
   (let ((conser (symbol-value 'muerte::fast-cons)))




From ffjeld at common-lisp.net  Thu Jul 15 12:26:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 05:26:34 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1Bl5Jq-0007QO-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Export muerte:current-run-time-context.

Date: Thu Jul 15 05:26:34 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.31 movitz/packages.lisp:1.32
--- movitz/packages.lisp:1.31	Thu Jul 15 04:16:14 2004
+++ movitz/packages.lisp	Thu Jul 15 05:26:34 2004
@@ -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.31 2004/07/15 11:16:14 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.32 2004/07/15 12:26:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1197,6 +1197,7 @@
 	   #:basic-restart
 	   #:illegal-object
 	   #:run-time-context
+	   #:current-run-time-context
 	   
 	   make-funobj
 	   funobj-type




From ffjeld at common-lisp.net  Thu Jul 15 21:06:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:19 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BlDQp-0004zK-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:19 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.46 movitz/image.lisp:1.47
--- movitz/image.lisp:1.46	Tue Jul 13 05:59:33 2004
+++ movitz/image.lisp	Thu Jul 15 14:06:19 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.46 2004/07/13 12:59:33 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.47 2004/07/15 21:06:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -300,14 +300,19 @@
     :initform 0)
    (values
     :binary-type #.(* 4 +movitz-multiple-values-limit+))
-   (malloc
+   (malloc-pointer-words
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (malloc-buffer
-    :binary-type lu32
-    :initform 0)
+   (malloc-non-pointer-words
+    :binary-type code-vector-word
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function)
+;;;   (malloc-buffer
+;;;    :binary-type lu32
+;;;    :initform 0)
    (default-interrupt-trampoline
        :map-binary-write 'movitz-intern-code-vector
      :binary-tag :primitive-function




From ffjeld at common-lisp.net  Thu Jul 15 21:06:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:24 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1BlDQu-0005dy-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:24 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.32 movitz/packages.lisp:1.33
--- movitz/packages.lisp:1.32	Thu Jul 15 05:26:34 2004
+++ movitz/packages.lisp	Thu Jul 15 14:06:24 2004
@@ -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.32 2004/07/15 12:26:34 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.33 2004/07/15 21:06:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1141,11 +1141,13 @@
 
 	   #:map-heap-words
 	   #:map-stack-words
-	   #:malloc-clumps
-	   #:malloc-data-clumps
-	   #:malloc-cons-pointer
 	   #:malloc-buffer-start
 	   #:malloc-end
+	   
+	   #:malloc-pointer-words
+	   #:malloc-non-pointer-words
+	   #:%memory-map%
+	   #:%memory-map-roots%
 
 	   #:%word-offset
 	   #:%run-time-context-slot




From ffjeld at common-lisp.net  Thu Jul 15 21:06:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:28 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BlDQy-0005k8-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:28 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.27 movitz/special-operators.lisp:1.28
--- movitz/special-operators.lisp:1.27	Wed Jul 14 17:29:19 2004
+++ movitz/special-operators.lisp	Thu Jul 15 14:06:28 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.27 2004/07/15 00:29:19 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.28 2004/07/15 21:06:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -553,11 +553,16 @@
 				   (setq side-effects t))
 				 (setq modifies (modifies-union modifies sub-modifies))
 				 code))))
-		       (setf (assembly-macro-expander :call-global-constant amenv)
+		       (setf (assembly-macro-expander :call-global-pf amenv)
 			 #'(lambda (expr)
 			     (destructuring-bind (name)
 				 (cdr expr)
 			       `((:globally (:call (:edi (:edi-offset ,name))))))))
+		       (setf (assembly-macro-expander :call-local-pf amenv)
+			 #'(lambda (expr)
+			     (destructuring-bind (name)
+				 (cdr expr)
+			       `((:locally (:call (:edi (:edi-offset ,name))))))))
 		       (setf (assembly-macro-expander :warn amenv)
 			 #'(lambda (expr)
 			     (apply #'warn (cdr expr))




From ffjeld at common-lisp.net  Thu Jul 15 21:06:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BlDR4-0005zg-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:33 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.27 movitz/losp/los0-gc.lisp:1.28
--- movitz/losp/los0-gc.lisp:1.27	Thu Jul 15 04:22:08 2004
+++ movitz/losp/los0-gc.lisp	Thu Jul 15 14:06:33 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.27 2004/07/15 11:22:08 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.28 2004/07/15 21:06:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -182,71 +182,67 @@
 	    (:ret))))
     (do-it)))
 
-(defun los0-malloc-clumps (clumps)
-  (check-type clumps (integer 0 160000))
+(define-primitive-function los0-malloc-pointer-words (words)
+  "Number of words in EAX/fixnum. Result in EAX with tag :other."
   (macrolet
       ((do-it ()
-	 `(with-inline-assembly (:returns :eax)
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:addl 4 :eax)
+	    (:andl -8 :eax)
+	    (:movl :eax :ebx)		; Save count for later
 	   retry
-	    (:compile-form (:result-mode :ebx) clumps)
-	    (:declare-label-set retry-jumper (retry))
-	    (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t)
-			       'retry-jumper)
-			     (:edi (:edi-offset atomically-status))))
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :ecx)
-	    (:leal ((:ebx 2) :ecx) :eax)
+	    (:leal (:ecx :eax) :eax)
 	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 		   :eax)
 	    (:ja '(:sub-program ()
-		   (:int 113)))
+		   (:int 113)
+		   (:movl :ebx :eax)	; Restore count in EAX before retry
+		   (:jmp 'retry)))
 	    (:movl :eax (:edx 2))
-	    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
-			     (:edi (:edi-offset atomically-status))))
-	    (:movl ,(movitz:tag :infant-object) (:edx :ecx 6))
+	    (:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+)))
 	    (:leal (:edx :ecx 8) :eax)		
 	    (:xorl :ecx :ecx)
-	   init-loop			; Now init eax number of clumps.
-	    (:movl :edi (:eax (:ecx 2) -6))
-	    (:movl :edi (:eax (:ecx 2) -2))
+	   init-loop			; Now init ebx number of words
+	    (:movl :edi (:eax :ecx ,(- (movitz:tag :other))))
 	    (:addl 4 :ecx)
 	    (:cmpl :ebx :ecx)
-	    (:jb 'init-loop))))
+	    (:jb 'init-loop)
+	    (:ret))))
     (do-it)))
 
-(defun los0-malloc-data-clumps (clumps)
-  (check-type clumps (integer 0 160000))
+(define-primitive-function los0-malloc-non-pointer-words (words)
+  "Number of words in EAX/fixnum. Result in EAX with tag :other."
   (macrolet
       ((do-it ()
-	 `(with-inline-assembly (:returns :eax)
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:addl 4 :eax)
+	    (:andl -8 :eax)
+	    (:movl :eax :ebx)		; Save count for later
 	   retry
-	    (:compile-form (:result-mode :ebx) clumps)
-	    (:declare-label-set retry-jumper (retry))
-	    (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t)
-			       'retry-jumper)
-			     (:edi (:edi-offset atomically-status))))
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 	    (:movl (:edx 2) :ecx)
-	    (:leal ((:ebx 2) :ecx) :eax)
+	    (:leal (:ecx :eax) :eax)
 	    (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 		   :eax)
 	    (:ja '(:sub-program ()
-		   (:int 113)))
+		   (:int 113)
+		   (:movl :ebx :eax)	; Restore count in EAX before retry
+		   (:jmp 'retry)))
 	    (:movl :eax (:edx 2))
-	    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
-			     (:edi (:edi-offset atomically-status))))
-
-	    (:movl #.(movitz:tag :infant-object) (:edx :ecx 6))
-	    (:leal (:edx :ecx 8) :eax))))
+	    (:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+)))
+	    (:leal (:edx :ecx 8) :eax)	; Now EAX is a valid pointer
+	    (:ret))))
     (do-it)))
 
-(defun install-los0-consing (&key (run-time-context (current-run-time-context))
+
+(defun install-los0-consing (&key (context (current-run-time-context))
 				  (kb-size 1024)
 				  duo-space)
-  "Install the 'Los0' GC architecture on run-time-context."
-  (setf (%run-time-context-slot 'nursery-space run-time-context)
-    (or duo-space
-	(allocate-duo-space (* kb-size #x100))))
+  "Install the 'Los0' GC architecture on run-time-context CONTEXT.
+Either use an explicitly provided DUO-SPACE, or allocate a fresh
+duo-space where each space is KB-SIZE kilobytes."
   (setf (exception-handler 113)
     (lambda (exception interrupt-frame)
       (declare (ignore exception interrupt-frame))
@@ -259,41 +255,30 @@
 	   (break "Los0 GC keyboard poll."))
 	  ((nil)
 	   (return))))))
-  (flet ((install-primitive (name slot)
-	   (let ((code-vector (symbol-value name)))
-	     (check-type code-vector code-vector)
-	     (setf (%run-time-context-slot slot run-time-context) code-vector))))
-    (install-primitive 'los0-fast-cons 'muerte::fast-cons)
-    (install-primitive 'los0-box-u32-ecx 'muerte::box-u32-ecx)
-    (install-primitive 'los0-get-cons-pointer 'muerte::get-cons-pointer)
-    (install-primitive 'los0-cons-commit 'muerte::cons-commit))
-  (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
-    (setf (symbol-function 'muerte:malloc-clumps)
-      (symbol-function 'los0-malloc-clumps))
-    (setf (symbol-function 'los0-malloc-clumps)
-      old-malloc))
-  (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
-    (setf (symbol-function 'muerte:malloc-data-clumps)
-      (symbol-function 'los0-malloc-data-clumps))
-    (setf (symbol-function 'los0-malloc-data-clumps)
-      old-malloc-data))
-  (values))
-
-(defun install-old-consing ()
-  (let ((conser (symbol-value 'muerte::fast-cons)))
-    (check-type conser vector)
-    (setf (%run-time-context-slot 'muerte::fast-cons)
-      conser))
-  (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
-    (setf (symbol-function 'muerte:malloc-clumps)
-      (symbol-function 'los0-malloc-clumps))
-    (setf (symbol-function 'los0-malloc-clumps)
-      old-malloc))
-  (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps)))
-    (setf (symbol-function 'muerte:malloc-data-clumps)
-      (symbol-function 'los0-malloc-data-clumps))
-    (setf (symbol-function 'los0-malloc-data-clumps)
-      old-malloc-data))
+  (let* ((actual-duo-space (or duo-space
+			       (allocate-duo-space (* kb-size #x100))))
+	 (last-location (object-location (cons 1 2))))
+    (macrolet ((install-primitive (name slot)
+		 `(let ((code-vector (symbol-value ',name)))
+		    (check-type code-vector code-vector)
+		    (if (eq context (current-run-time-context))
+			;; The point of this is to not trigger CLOS bootstrapping.
+			(setf (%run-time-context-slot ',slot) code-vector)
+		      (setf (%run-time-context-slot ',slot context) code-vector)))))
+      (install-primitive los0-fast-cons muerte::fast-cons)
+      (install-primitive los0-box-u32-ecx muerte::box-u32-ecx)
+      (install-primitive los0-get-cons-pointer muerte::get-cons-pointer)
+      (install-primitive los0-cons-commit muerte::cons-commit)
+      (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words)
+      (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words))
+    (if (eq context (current-run-time-context))
+	(setf (%run-time-context-slot 'muerte::nursery-space)
+	  actual-duo-space)
+      (setf (%run-time-context-slot 'muerte::nursery-space context)
+	actual-duo-space))
+    ;; Pretend that the heap stops here, so that we don't have to scan
+    ;; the entire tail end of memory, which isn't going to be used.
+    (setf (cdar muerte::%memory-map-roots%) last-location))
   (values))
 
 (defun object-in-space-p (space object)
@@ -387,8 +372,8 @@
 			     (setf (memref (object-location x) 0 0 :lisp) forward-x)
 			     forward-x)))))))))
 	;; Scavenge roots
-	(map-heap-words evacuator 0 (+ (malloc-buffer-start)
-				       (* 2 (malloc-cons-pointer))))
+	(dolist (range muerte::%memory-map-roots%)
+	  (map-heap-words evacuator (car range) (cdr range)))
 	(map-stack-words evacuator (current-stack-frame))
 	;; Scan newspace, Cheney style.
 	(loop with newspace-location = (+ 2 (object-location newspace))




From ffjeld at common-lisp.net  Thu Jul 15 21:06:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:38 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp 
Message-ID: <E1BlDR8-00061x-00@common-lisp.net>

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

Modified Files:
	malloc-init.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:38 2004
Author: ffjeld

Index: movitz/losp/lib/malloc-init.lisp
diff -u movitz/losp/lib/malloc-init.lisp:1.4 movitz/losp/lib/malloc-init.lisp:1.5
--- movitz/losp/lib/malloc-init.lisp:1.4	Wed Jul  7 10:37:11 2004
+++ movitz/losp/lib/malloc-init.lisp	Thu Jul 15 14:06:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jan  9 15:57:22 2002
 ;;;;                
-;;;; $Id: malloc-init.lisp,v 1.4 2004/07/07 17:37:11 ffjeld Exp $
+;;;; $Id: malloc-init.lisp,v 1.5 2004/07/15 21:06:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,14 +20,18 @@
 (in-package muerte.lib)
 
 (let* ((stack-vector (%run-time-context-slot 'muerte::stack-vector))
-       (kernel-end (+ (* 4 (muerte:object-location stack-vector))
-		      8 (* 4 (array-dimension stack-vector 0))))
-       (memsize (muerte.x86-pc::memory-size))
-       (start (truncate (+ kernel-end 4095) 4096)))
-  (muerte:malloc-initialize start (- (* memsize #x100) start))
-  (loop for x from (truncate kernel-end 4) below (* start 1024)
+       ;; We assume the kernel static are ends with the stack-vector.
+       (kernel-end-location (+ 2 (muerte:object-location stack-vector)
+			       (array-dimension stack-vector 0)))
+       (memsize-mb (muerte.x86-pc::memory-size))
+       ;; Start-location is kernel-end rounded up to the next 4096 edge.
+       (start-location (logand (+ kernel-end-location (1- 4096/4)) -4096/4))
+       ;; End-location is the end of the memory.
+       (end-location (* (1- memsize-mb) 1024 1024/4)))
+  (muerte:malloc-initialize start-location end-location)
+  (setf (cdar muerte::%memory-map%) end-location)
+  (loop for x from kernel-end-location below start-location
       do (setf (memref x 0 0 :unsigned-byte32) 0))
-  ;; (format t "Memory: ~D MB. Malloc area at ~D K.~%" memsize (* start 4))
   (values))
 
 




From ffjeld at common-lisp.net  Thu Jul 15 21:06:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:42 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BlDRC-000688-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:42 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.35 movitz/losp/muerte/arrays.lisp:1.36
--- movitz/losp/muerte/arrays.lisp:1.35	Sun Jul 11 16:02:33 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Jul 15 14:06:42 2004
@@ -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.35 2004/07/11 23:02:33 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.36 2004/07/15 21:06:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -236,7 +236,7 @@
 		  :u32
 		   (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 			  :ecx)
-		   (:call-global-constant box-u32-ecx)
+		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'return)
 		  :u8 :code
 		   (:movl :ebx :ecx)
@@ -336,7 +336,7 @@
 		   ;; u32?
 		   (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
 		   (:jne 'not-u32-vector)
-		   (:call-global-constant unbox-u32)
+		   (:call-local-pf unbox-u32)
 		   (:movl :ecx
 			  (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 		   (:jmp 'return)
@@ -547,7 +547,7 @@
 	    `(funcall%unsafe ,reader , at args))))
 
 (defun make-basic-vector%character (dimensions fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+  (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ dimensions 3) 4)))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       dimensions)
@@ -570,7 +570,7 @@
     array))
 
 (defun make-basic-vector%u32 (dimensions fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words dimensions)))
+  (let ((array (malloc-non-pointer-words (+ 2 dimensions))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       dimensions)
@@ -592,7 +592,7 @@
     array))
 
 (defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words (truncate (+ length 3) 4))))
+  (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ length 3) 4)))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       length)
@@ -614,7 +614,7 @@
     array))
 
 (defun make-basic-vector%bit (length fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words (truncate (+ length 31) 32))))
+  (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ length 31) 32)))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       length)
@@ -636,7 +636,7 @@
     array))
 
 (defun make-basic-vector%code (dimensions fill-pointer initial-element initial-contents)
-  (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+  (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ dimensions 3) 4)))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       dimensions)
@@ -659,7 +659,7 @@
 
 (defun make-basic-vector%t (dimensions fill-pointer initial-element initial-contents)
   (check-type dimensions (and fixnum (integer 0 *)))
-  (let ((array (malloc-words dimensions)))
+  (let ((array (malloc-pointer-words (+ 2 dimensions))))
     (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
 		  0 :lisp)
       dimensions)




From ffjeld at common-lisp.net  Thu Jul 15 21:06:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:46 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BlDRG-0006CO-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:46 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.26 movitz/losp/muerte/basic-macros.lisp:1.27
--- movitz/losp/muerte/basic-macros.lisp:1.26	Sun Jul 11 16:04:14 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Jul 15 14:06:46 2004
@@ -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.26 2004/07/11 23:04:14 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.27 2004/07/15 21:06:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -434,7 +434,7 @@
     `(eq ',x ,y))
    (t `(with-inline-assembly (:returns :boolean-zf=1)
 	 (:compile-two-forms (:eax :ebx) ,x ,y)
-	 (:call-global-constant fast-eql)))))
+	 (:call-global-pf fast-eql)))))
 
 (define-compiler-macro values (&rest sub-forms)
   `(inline-values , at sub-forms))
@@ -523,23 +523,6 @@
 									     :cl :muerte.cl)))))
      ',symbol))
 
-  
-
-(defmacro inline-malloc (size &key (tag :other) other-tag wide-other-tag)
-  (assert (not (and (not other-tag) wide-other-tag)))
-  `(with-inline-assembly (:returns :eax :side-effects t)
-     ,@(if (integerp size)
-	   `((:movl ,size :ebx))
-	 `((:compile-form (:result-mode :ebx) ,size)
-	   (:shrl ,movitz::+movitz-fixnum-shift+ :ebx)))
-     (:globally (:call (:edi (:edi-offset malloc))))
-     (:addl ,(if (integerp tag) tag (movitz::tag tag)) :eax)
-     ,@(when (and (eq tag :other) other-tag (not wide-other-tag))
-	 `((:movb ,(movitz::tag other-tag) (:eax ,movitz:+other-type-offset+))))
-     ,@(when (and (eq tag :other) other-tag wide-other-tag)
-	 `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz:tag other-tag))
-		  (:eax ,movitz:+other-type-offset+))))))
-
 (defmacro check-type (place type &optional type-string)
   (if (not (stringp type-string))
       `(let ((place-value ,place))
@@ -1051,7 +1034,7 @@
        (:compile-form (:result-mode :eax) ,symbol)
        (:cmpl :edi :eax)
        (:je 'boundp-done)		; if ZF=0, then CF=0
-       (:call-global-constant dynamic-find-binding)
+       (:call-local-pf dynamic-find-binding)
        (:jc 'boundp-done)
        (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax)
        (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))




From ffjeld at common-lisp.net  Thu Jul 15 21:06:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:51 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp 
Message-ID: <E1BlDRL-0006Ff-00@common-lisp.net>

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

Modified Files:
	cons.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:51 2004
Author: ffjeld

Index: movitz/losp/muerte/cons.lisp
diff -u movitz/losp/muerte/cons.lisp:1.4 movitz/losp/muerte/cons.lisp:1.5
--- movitz/losp/muerte/cons.lisp:1.4	Sat Apr 17 08:34:03 2004
+++ movitz/losp/muerte/cons.lisp	Thu Jul 15 14:06:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.4 2004/04/17 15:34:03 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.5 2004/07/15 21:06:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -244,4 +244,4 @@
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) car)
     (:compile-form (:result-mode :ebx) cdr)
-    (:call-global-constant fast-cons)))
+    (:call-local-pf fast-cons)))




From ffjeld at common-lisp.net  Thu Jul 15 21:06:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:55 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1BlDRP-0006JZ-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:55 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.8 movitz/losp/muerte/defstruct.lisp:1.9
--- movitz/losp/muerte/defstruct.lisp:1.8	Fri May 21 02:41:39 2004
+++ movitz/losp/muerte/defstruct.lisp	Thu Jul 15 14:06:55 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.8 2004/05/21 09:41:39 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.9 2004/07/15 21:06:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,7 +26,7 @@
 (defun copy-structure (object)
   (check-type object structure-object)
   (let* ((length (structure-object-length object))
-	 (copy (malloc-words length)))
+	 (copy (malloc-pointer-words (+ 2 length))))
     (setf (memref copy -6 0 :lisp)
       (memref object -6 0 :lisp))
     (setf (memref copy -6 1 :unsigned-byte32)
@@ -231,20 +231,20 @@
 		      if (and constructor (symbolp constructor))
 		      collect
 			`(defun ,constructor (&key , at key-lambda)
-			   (let ((s (malloc-words ,(length slot-names))))
+			   (let ((s (malloc-pointer-words ,(+ 2 (length slot-names)))))
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
-						    0 :lisp)
+					   0 :lisp)
 			       ',struct-name)
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type)
-						    0 :unsigned-byte8)
+					   0 :unsigned-byte8)
 			       #.(movitz::tag :defstruct))
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length)
-						    0 :unsigned-byte16)
+					   0 :unsigned-byte16)
 			       ,(length slot-names))
 			     ,@(loop for slot-name in slot-names as i upfrom 0 collecting
 				     `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct
-										 'movitz::slot0)
-							     ,i :lisp)
+									'movitz::slot0)
+						    ,i :lisp)
 					,slot-name))
 			     s))
 		      else if (and constructor (listp constructor))
@@ -253,7 +253,7 @@
 			       (boa-lambda-list (cdr constructor))
 			       (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list)))
 			  `(defun ,boa-constructor ,boa-lambda-list
-			     (let ((s (malloc-words ,(length slot-names))))
+			     (let ((s (malloc-pointer-words ,(+ 2 (length slot-names)))))
 			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
 						      0 :lisp)
 				 ',struct-name)




From ffjeld at common-lisp.net  Thu Jul 15 21:06:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:06:59 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1BlDRT-0006PG-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:06:59 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.15 movitz/losp/muerte/functions.lisp:1.16
--- movitz/losp/muerte/functions.lisp:1.15	Tue Jul 13 15:41:48 2004
+++ movitz/losp/muerte/functions.lisp	Thu Jul 15 14:06:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.15 2004/07/13 22:41:48 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.16 2004/07/15 21:06:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -351,8 +351,8 @@
        (make-array (length code-vector)
 		   :element-type 'code
 		   :initial-contents code-vector))))
-  (let ((funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
-				 (length constants)))))
+  (let ((funobj (malloc-pointer-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+					 (length constants)))))
     (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
       #.(movitz:tag :funobj))
     (setf (funobj-name funobj) name
@@ -395,8 +395,8 @@
 
 (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj)))
   (let* ((num-constants (funobj-num-constants old-funobj))
-	 (funobj (malloc-words (+ -2 #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
-				  num-constants))))
+	 (funobj (malloc-pointer-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+					  num-constants))))
     (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
       (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16))
     (setf (funobj-num-constants funobj) num-constants)




From ffjeld at common-lisp.net  Thu Jul 15 21:07:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:04 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BlDRY-0006Y0-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:04 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.20 movitz/losp/muerte/inspect.lisp:1.21
--- movitz/losp/muerte/inspect.lisp:1.20	Tue Jul 13 15:42:38 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul 15 14:07:04 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.20 2004/07/13 22:42:38 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.21 2004/07/15 21:07:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,17 @@
 
 (in-package muerte)
 
+(define-global-variable %memory-map%
+    '((0 . #x80000))			; 0-2 MB
+  "This is a list of the active memory ranges. Each element is a cons-cell
+where the car is the start-location and the cdr the end-location.
+A 'location' is a fixnum interpreted as a pointer (i.e. the pointer value
+with the lower two bits masked off).
+This variable should be initialized during bootup initialization.")
+
+(defvar %memory-map-roots% '((0 . #x80000))
+  "The memory-map that is to be scanned for pointer roots.")
+
 (define-compiler-macro check-stack-limit ()
   `(with-inline-assembly (:returns :nothing)
      (:locally (:bound (:edi (:edi-offset stack-bottom)) :esp))))
@@ -183,46 +194,17 @@
     (symbol
      (copy-symbol old t))
     (vector
-     (make-array (array-dimension old 0)
-		 :element-type (array-element-type old)
-		 :initial-contents old
-		 :fill-pointer (fill-pointer old)))
+     (let ((new (make-array (array-dimension old 0)
+			    :element-type (array-element-type old)
+			    :initial-contents old)))
+       (when (array-has-fill-pointer-p old)
+	 (setf (fill-pointer new) (fill-pointer old)))
+       new))
     (function
      (copy-funobj old))
     (structure-object
      (copy-structure old))))
 
-(defun malloc-clumps (clumps)
-  "Allocate general-purpose memory, i.e. including pointers.
-The unit clump is 8 bytes, or two words."
-  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
-	     (:compile-form (:result-mode :ebx) clumps)
-	     (:shll 1 :ebx)
-	     (:globally (:call (:edi (:edi-offset malloc))))
-	     (:addl #.(movitz::tag :other) :eax)
-	     (:xorl :ecx :ecx)
-	    reset-loop
-	     (:movl :edi (:eax :ecx -6))
-	     (:addl 4 :ecx)
-	     (:cmpl :ecx :ebx)
-	     (:jae 'reset-loop))))
-    #+ignore
-    (dotimes (i (* 2 clumps))
-      (setf (memref x -6 i :lisp) nil))
-    x))
-
-(defun malloc-data-clumps (clumps)
-  "Allocate memory for non-pointer data (i.e. doesn't require initialization)."
-  ;; Never mind, this is the stupid default implementation.
-  (malloc-clumps clumps))
-
-(defun malloc-words (words)
-  "Allocate space for at least (+ 2 words) cells/words."
-  (malloc-clumps (1+ (truncate (1+ words) 2))))
-
-(defun malloc-data-words (words)
-  (malloc-data-clumps (1+ (truncate (1+ words) 2))))
-
 (defun location-in-object-p (object location)
   "Is location inside object?"
   (let ((object-location (object-location object)))
@@ -315,7 +297,7 @@
 (defun copy-bignum (old)
   (check-type old bignum)
   (let* ((length (%bignum-bigits old))
-	 (new (malloc-data-clumps (1+ (truncate length 2)))))
+	 (new (malloc-non-pointer-words (1+ length))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
       (:compile-form (:result-mode :edx) length)




From ffjeld at common-lisp.net  Thu Jul 15 21:07:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlDRc-0006jh-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:08 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.65 movitz/losp/muerte/integers.lisp:1.66
--- movitz/losp/muerte/integers.lisp:1.65	Wed Jul 14 17:26:26 2004
+++ movitz/losp/muerte/integers.lisp	Thu Jul 15 14:07:08 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.65 2004/07/15 00:26:26 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.66 2004/07/15 21:07:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,7 +44,7 @@
 (define-compiler-macro evenp (x)
   `(with-inline-assembly (:returns :boolean-zf=1)
      (:compile-form (:result-mode :eax) ,x)
-     (:call-global-constant unbox-u32)
+     (:call-global-pf unbox-u32)
      (:testb 1 :cl)))
 
 (defun evenp (x)
@@ -53,7 +53,7 @@
 (define-compiler-macro oddp (x)
   `(with-inline-assembly (:returns :boolean-zf=0)
      (:compile-form (:result-mode :eax) ,x)
-     (:call-global-constant unbox-u32)
+     (:call-global-pf unbox-u32)
      (:testb 1 :cl)))
 
 (defun oddp (x)
@@ -139,13 +139,13 @@
 			  (:movl :eax :ecx)
 			  (:jns 'fix-fix-negative)
 			  (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-			  (:call-global-constant box-u32-ecx)
+			  (:call-local-pf box-u32-ecx)
 			  (:jmp 'fix-fix-ok)
 			  fix-fix-negative
 			  (:jz 'fix-double-negative)
 			  (:negl :ecx)
 			  (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-			  (:call-global-constant box-u32-ecx)
+			  (:call-local-pf box-u32-ecx)
 			  (:movl ,(dpb 1 (byte 16 16)
 				   (movitz:tag :bignum #xff))
 			   (:eax ,movitz:+other-type-offset+))
@@ -175,7 +175,7 @@
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
 		   (:jc 'retry-not-size1)
-		   (:call-global-constant box-u32-ecx)
+		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'pfix-pbig-done)
 		  retry-not-size1
 		   (:compile-form (:result-mode :eax) y)
@@ -188,7 +188,7 @@
 				    (:edi (:edi-offset atomically-status))))
 		   (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			  :eax)		; Number of words
-		   (:call-global-constant get-cons-pointer)
+		   (:call-local-pf get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -219,7 +219,7 @@
 		   (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
-		   (:call-global-constant cons-commit)
+		   (:call-local-pf cons-commit)
 		   (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				    (:edi (:edi-offset atomically-status))))
 		   
@@ -241,7 +241,7 @@
 		   (:compile-form (:result-mode :ecx) x)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
-		   (:call-global-constant box-u32-ecx)
+		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'pfix-pbig-done)
 		  retry-not-size1
 		   (:compile-form (:result-mode :eax) y)
@@ -254,7 +254,7 @@
 				    (:edi (:edi-offset atomically-status))))
 		   (:leal ((:ecx 1) ,(* 1 movitz:+movitz-fixnum-factor+))
 			  :eax)		; Number of words
-		   (:call-global-constant get-cons-pointer)
+		   (:call-local-pf get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -285,7 +285,7 @@
 		   (:subl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
-		   (:call-global-constant cons-commit)
+		   (:call-local-pf cons-commit)
 		   (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				    (:edi (:edi-offset atomically-status))))
 		   
@@ -310,7 +310,7 @@
 		     (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
 		     (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
 		     (:jc 'retry-not-size1)
-		     (:call-global-constant box-u32-ecx)
+		     (:call-local-pf box-u32-ecx)
 		     (:jmp 'pfix-pbig-done)
 		    retry-not-size1
 		     (:compile-form (:result-mode :eax) y)
@@ -323,7 +323,7 @@
 				      (:edi (:edi-offset atomically-status))))
 		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			    :eax)	; Number of words
-		     (:call-global-constant get-cons-pointer)
+		     (:call-local-pf get-cons-pointer)
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -374,7 +374,7 @@
 		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 		    no-expansion
-		     (:call-global-constant cons-commit)
+		     (:call-local-pf cons-commit)
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))
 		    pfix-pbig-done)
@@ -842,16 +842,16 @@
 	       (check-type n1 (signed-byte 30))
 	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
 		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-constant fast-compare-fixnum-real))))
+		  (:call-global-pf fast-compare-fixnum-real))))
 	    ((movitz:movitz-constantp n2)
 	     (let ((n2 (movitz::movitz-eval n2)))
 	       (check-type n2 (signed-byte 30))
 	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
 		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-constant fast-compare-real-fixnum))))
+		  (:call-global-pf fast-compare-real-fixnum))))
 	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
 		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-constant fast-compare-two-reals))))))
+		  (:call-global-pf fast-compare-two-reals))))))
 
      (defun ,2op-name (n1 n2)
        (,2op-name n1 n2))
@@ -917,7 +917,7 @@
 (define-compiler-macro =%2op (n1 n2 &environment env)
   (cond
    ((movitz:movitz-constantp n1 env)
-    (let ((n1 (movitz::movitz-eval n1 env)))
+    (let ((n1 (movitz:movitz-eval n1 env)))
       (etypecase n1
 	((eql 0)
 	 `(do-result-mode-case ()
@@ -931,16 +931,16 @@
 	((signed-byte 30)
 	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
 	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	    (:call-global-constant fast-compare-fixnum-real))))))
+	    (:call-global-pf fast-compare-fixnum-real)))
+	(integer
+	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
+	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+	    (:call-global-pf fast-compare-two-reals))))))
    ((movitz:movitz-constantp n2 env)
-    (let ((n2 (movitz::movitz-eval n2 env)))
-      (check-type n2 (signed-byte 30))
-      `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
-	 (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	 (:call-global-constant fast-compare-real-fixnum))))
+    `(=%2op ,n2 ,n1))
    (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
 	 (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	 (:call-global-constant fast-compare-two-reals)))))
+	 (:call-global-pf fast-compare-two-reals)))))
 
 (define-number-relational = =%2op nil :defun-p nil)
 
@@ -1191,7 +1191,7 @@
 		     (:store-lexical (:lexical-binding d0) :eax :type fixnum)
 		     (:store-lexical (:lexical-binding d1) :edx :type fixnum)
 		     (:compile-form (:result-mode :eax)
-				    (malloc-data-words 3))
+				    (malloc-non-pointer-words 3))
 		     (:movl ,(dpb (* 2 movitz:+movitz-fixnum-factor+)
 				  (byte 16 16) (movitz:tag :bignum 0))
 			    (:eax ,movitz:+other-type-offset+))
@@ -1219,7 +1219,7 @@
 		     (:shrdl ,movitz::+movitz-fixnum-shift+ :edx :ecx)
 		     (:movl :edi :edx)
 		     (:cld)
-		     (:call-global-constant box-u32-ecx)
+		     (:call-local-pf box-u32-ecx)
 		     (:jmp 'fixnum-done)
 		     
 		    u32-negative-result
@@ -1228,7 +1228,7 @@
 		     (:movl :edi :edx)
 		     (:cld)
 		     (:negl :ecx)
-		     (:call-global-constant box-u32-ecx)
+		     (:call-local-pf box-u32-ecx)
 		     (:xorl #xff00 (:eax ,movitz:+other-type-offset+))
 		     (:jmp 'fixnum-done)
 
@@ -1255,7 +1255,7 @@
 			      :ecx)
 		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			    :eax)
-		     (:call-global-constant get-cons-pointer) ; New bignum into EAX
+		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
 
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		     (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
@@ -1301,7 +1301,7 @@
 		     (:cld)		; EAX, EDX, and ESI are GC roots again.
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
-		     (:call-global-constant cons-commit)
+		     (:call-local-pf cons-commit)
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))
 		     (:compile-form (:result-mode :ebx) x)
@@ -1373,7 +1373,7 @@
 		     (:movl :edi :eax)
 		     (:cld)
 		     (:pushl :edx)
-		     (:call-global-constant box-u32-ecx)
+		     (:call-local-pf box-u32-ecx)
 		     (:popl :ebx)
 		     (:jmp 'done)
 		    not-size1
@@ -1388,7 +1388,7 @@
 				      (:edi (:edi-offset atomically-status))))
 
 		     (:leal ((:ecx 1) 4) :eax) ; Number of words
-		     (:call-global-constant get-cons-pointer) ; New bignum into EAX
+		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
 		     
 
 		     (:store-lexical (:lexical-binding r) :eax :type bignum)
@@ -1440,7 +1440,7 @@
 		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		     (:jmp 'fixnum-result) ; don't commit the bignum
 		    no-more-shrinkage
-		     (:call-global-constant cons-commit)
+		     (:call-local-pf cons-commit)
 		    fixnum-result
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))	     
@@ -1639,14 +1639,14 @@
 		((positive-bignum positive-fixnum)
 		 (with-inline-assembly (:returns :eax)
 		   (:compile-form (:result-mode :eax) x)
-		   (:call-global-constant unbox-u32)
+		   (:call-global-pf unbox-u32)
 		   (:compile-form (:result-mode :eax) y)
 		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx)
 		   (:andl :ecx :eax)))
 		((positive-fixnum positive-bignum)
 		 (with-inline-assembly (:returns :eax)
 		   (:compile-form (:result-mode :eax) y)
-		   (:call-global-constant unbox-u32)
+		   (:call-global-pf unbox-u32)
 		   (:compile-form (:result-mode :eax) x)
 		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx)
 		   (:andl :ecx :eax)))
@@ -1681,7 +1681,7 @@
 	    ((t positive-fixnum)
 	     (with-inline-assembly (:returns :eax :type fixnum)
 	       (:compile-form (:result-mode :eax) integer1)
-	       (:call-global-constant unbox-u32)
+	       (:call-global-pf unbox-u32)
 	       (:shll ,movitz:+movitz-fixnum-shift+ :ecx)
 	       (:compile-form (:result-mode :eax) integer2)
 	       (:notl :ecx)
@@ -1896,7 +1896,7 @@
 	       (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 				  'retry-jumper-ones-expanded-bignum)
 				(:edi (:edi-offset atomically-status))))
-	       (:call-global-constant get-cons-pointer)
+	       (:call-local-pf get-cons-pointer)
 	       (:shll 16 :ecx)
 	       (:addl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) ; add 1 for index->size
 	       (:movl :ecx (:eax ,movitz:+other-type-offset+))
@@ -1904,7 +1904,7 @@
 	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
 		       ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header.
 		      :ecx)
-	       (:call-global-constant cons-commit)
+	       (:call-local-pf cons-commit)
 	       (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				(:edi (:edi-offset atomically-status))))
 	       ;; Have fresh bignum in EAX, now fill it with ones.
@@ -2013,7 +2013,7 @@
 		 (:movl :ebx :eax)
 		 (:jmp 'done-u32)
 		cant-return-same
-		 (:call-global-constant box-u32-ecx)
+		 (:call-local-pf box-u32-ecx)
 		done-u32
 		 )))
 	 (do-it)))
@@ -2097,7 +2097,7 @@
 		     ;; Now add 1 for index->size, 1 for header, and 1 for tmp storage before shift.
 		     (:addl ,(* 3 movitz:+movitz-fixnum-factor+) :eax)
 		     (:pushl :eax)
-		     (:call-global-constant get-cons-pointer)
+		     (:call-local-pf get-cons-pointer)
 		     ;; (:store-lexical (:lexical-binding r) :eax :type t)
 		     (:popl :ecx)
 		     (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header.
@@ -2200,7 +2200,7 @@
 		     (:movl :ebx :eax)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
-		     (:call-global-constant cons-commit)
+		     (:call-local-pf cons-commit)
 		    return-fixnum
 		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
 				      (:edi (:edi-offset atomically-status))))
@@ -2231,7 +2231,7 @@
 	`(with-inline-assembly (:returns :register
 					 :type ,result-type)
 	   (:compile-form (:result-mode :eax) ,integer)
-	   (:call-global-constant unbox-u32)
+	   (:call-global-pf unbox-u32)
 	   (:andl ,(mask-field (byte size position) -1) :ecx)
 	   ,@(unless (zerop position)
 	       `((:shrl ,position :ecx)))
@@ -2263,15 +2263,15 @@
 		   (:jz 'done)
 		   (:andl ,(mask-field (byte size 0) -1)
 			  :ecx)
-		   (:call-global-constant box-u32-ecx)
+		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'done))))
 	    nix
-	     (:call-global-constant unbox-u32)
+	     (:call-global-pf unbox-u32)
 	     ,@(unless (= 32 (- size position))
 		 `((:andl ,(mask-field (byte size position) -1) :ecx)))
 	     ,@(unless (zerop position)
 		 `((:shrl ,position :ecx)))
-	     (:call-global-constant box-u32-ecx)
+	     (:call-local-pf box-u32-ecx)
 	    done)))
        (t form))))
    (t form)))




From ffjeld at common-lisp.net  Thu Jul 15 21:07:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:13 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BlDRh-0006sq-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:13 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.13 movitz/losp/muerte/los-closette.lisp:1.14
--- movitz/losp/muerte/los-closette.lisp:1.13	Mon Jul 12 19:31:24 2004
+++ movitz/losp/muerte/los-closette.lisp	Thu Jul 15 14:07:13 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.13 2004/07/13 02:31:24 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.14 2004/07/15 21:07:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -119,7 +119,7 @@
 
 
 (defun allocate-std-instance (class slots)
-  (let ((instance (malloc-clumps 2)))
+  (let ((instance (malloc-pointer-words 4)))
     (setf (memref instance #.(bt:slot-offset 'movitz:movitz-struct 'movitz:type)
 		  0 :unsigned-byte8)
       #.(movitz:tag :std-instance))
@@ -988,6 +988,7 @@
 (defclass complex (number) () (:metaclass built-in-class))
 
 (defclass illegal-object (t) () (:metaclass built-in-class))
+(defclass infant-object (t) () (:metaclass built-in-class))
 
 (defclass run-time-context (t)
   ()
@@ -1110,7 +1111,7 @@
     (check-type class structure-class)
     (let* ((slots (class-slots class))
 	   (num-slots (length slots))
-	   (struct (malloc-words num-slots)))
+	   (struct (malloc-pointer-words (+ 2 num-slots))))
       (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
 		    0 :lisp)
 	(class-name class))




From ffjeld at common-lisp.net  Thu Jul 15 21:07:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BlDRm-000716-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:18 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.15 movitz/losp/muerte/memref.lisp:1.16
--- movitz/losp/muerte/memref.lisp:1.15	Sun Jul 11 16:00:41 2004
+++ movitz/losp/muerte/memref.lisp	Thu Jul 15 14:07:18 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.15 2004/07/11 23:00:41 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.16 2004/07/15 21:07:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -334,7 +334,7 @@
 		  (,index-var ,index))
 	      (with-inline-assembly (:returns :untagged-fixnum-ecx)
 		(:load-lexical (:lexical-binding ,value-var) :eax)
-		(:call-global-constant unbox-u32)
+		(:call-global-pf unbox-u32)
 		(:compile-two-forms (:ebx :eax) ,object-var ,index-var)
 		(:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env)))))))
 	(t (let ((value-var (gensym "memref-value-"))
@@ -348,7 +348,7 @@
 		    (,index-var ,index))
 		(with-inline-assembly (:returns :untagged-fixnum-ecx)
 		  (:load-lexical (:lexical-binding ,value-var) :eax)
-		  (:call-global-constant unbox-u32)
+		  (:call-global-pf unbox-u32)
 		  (:compile-two-forms (:eax :edx) ,index-var ,offset-var)
 		  (:load-lexical (:lexical-binding ,object-var) :ebx)
 		  (:std)
@@ -609,7 +609,7 @@
 	    (:addl :ecx :eax)
 	    (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address
 	    (,prefixes :movl (:eax) :ecx)
-	    (:call-global-constant box-u32-ecx)))
+	    (:call-local-pf box-u32-ecx)))
 	(:unsigned-byte16
 	 (cond
 	  ((and (eq 0 offset) (eq 0 index))




From ffjeld at common-lisp.net  Thu Jul 15 21:07:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:22 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BlDRq-0007Pv-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:22 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.28 movitz/losp/muerte/primitive-functions.lisp:1.29
--- movitz/losp/muerte/primitive-functions.lisp:1.28	Thu Jul 15 04:18:49 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Jul 15 14:07:22 2004
@@ -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.28 2004/07/15 11:18:49 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.29 2004/07/15 21:07:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -420,10 +420,12 @@
     (:movl :edi (:esp 4))		; terminate list
     (:jmp :ebx)))			; return
 
-(define-primitive-function malloc ()
-  "Stupid allocator.. Number of bytes in EBX. Result in EAX."
+(define-primitive-function malloc-pointer-words ()
+  "Stupid allocator.. Number of words in EAX/fixnum.
+Result in EAX, with tag :other."
   (with-inline-assembly (:returns :multiple-values)
-    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
+    (:movl :eax :ebx)
+    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:testb #xff :al)
     (:jnz '(:sub-program (not-initialized)
 	    (:int 110)
@@ -440,9 +442,52 @@
 	   (:halt)
 	   (:jmp 'failed)))
     (:movl :edx (:eax 4))		; new cons pointer
-    (:leal (:eax :ecx) :eax)
+    (:leal (:eax :ecx 6) :eax)
     (:ret)))
 
+(define-primitive-function malloc-non-pointer-words ()
+  "Stupid allocator.. Number of words in EAX/fixnum.
+Result in EAX, with tag 6."
+  (with-inline-assembly (:returns :multiple-values)
+    (:movl :eax :ebx)
+    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
+    (:testb #xff :al)
+    (:jnz '(:sub-program (not-initialized)
+	    (:int 110)
+	    (:halt)
+	    (:jmp 'not-initialized)))
+    (:addl 7 :ebx)
+    (:andb #xf8 :bl)
+    (:movl (:eax 4) :ecx)		; cons pointer to ECX
+    (:leal (:ebx :ecx) :edx)		; new roof to EDX
+    (:cmpl :edx (:eax))			; end of buffer?
+    (:jl '(:sub-program (failed)
+	   (:movl (:eax) :esi)
+	   (:int 112)
+	   (:halt)
+	   (:jmp 'failed)))
+    (:movl :edx (:eax 4))		; new cons pointer
+    (:leal (:eax :ecx 6) :eax)
+    (:ret)))
+
+(define-compiler-macro malloc-pointer-words (words)
+  `(with-inline-assembly (:returns :eax :type pointer)
+     (:compile-form (:result-mode :eax) ,words)
+     (:call-local-pf malloc-pointer-words)))
+
+(defun malloc-pointer-words (words)
+  (check-type words (integer 2 *))
+  (malloc-pointer-words words))
+
+(define-compiler-macro malloc-non-pointer-words (words)
+  `(with-inline-assembly (:returns :eax :type pointer)
+     (:compile-form (:result-mode :eax) ,words)
+     (:call-local-pf malloc-non-pointer-words)))
+
+(defun malloc-non-pointer-words (words)
+  (check-type words (integer 2 *))
+  (malloc-non-pointer-words words))
+
 (define-primitive-function muerte::get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
@@ -452,16 +497,8 @@
 	 ;; is never comitted.
 	 `(with-inline-assembly (:returns :multiple-values)
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movl :eax :ebx)
-	    (:call-global-constant malloc)
+	    (:call-local-pf malloc-pointer-words)
 	    (:locally (:movl (:edi (:edi-offset scratch0)) :ecx))
-	    (:leal (:eax 6) :eax)
-	    (:ret))
-	 #+ignore
-	 `(with-inline-assembly (:returns :multiple-values)
-	    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
-	    (:movl (:eax 4) :ecx)	; cons pointer to ECX
-	    (:leal (:eax :ecx 6) :eax)
 	    (:ret))))
     (do-it)))
 
@@ -471,36 +508,26 @@
   (macrolet
       ((do-it ()
 	 ;; Since get-cons-pointer is implemented as an (already committed)
-	 ;; malloc, this is a NOP
-	 `(with-inline-assembly (:returns :multiple-values)
-	    (:ret))
-	 #+ignore
+	 ;; malloc, this is a no-op.
 	 `(with-inline-assembly (:returns :multiple-values)
-	    (:pushl :eax)
-	    (:pushl :ebx)
-	    (:movl :ecx :ebx)
-	    (:call-global-constant malloc)
-	    (:popl :ebx)
-	    (:popl :eax)
 	    (:ret))))
     (do-it)))
 
 (defun malloc-initialize (buffer-start buffer-size)
-  "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units."
+  "BUFFER-START is the location from which to allocate.
+BUFFER-SIZE is the number of words in the buffer."
   (check-type buffer-start fixnum)
   (check-type buffer-size fixnum)
   (with-inline-assembly (:returns :nothing)
     (:compile-form (:result-mode :eax) buffer-start)
-    (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :eax)
-    (:locally (:movl :eax (:edi (:edi-offset malloc-buffer))))
+    (:locally (:movl :eax (:edi (:edi-offset nursery-space))))
     (:compile-form (:result-mode :ebx) buffer-size)
-    (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :ebx)
     (:movl :ebx (:eax))			; roof pointern
     (:movl 16 (:eax 4))))		; cons pointer
 
 (defun malloc-buffer-start ()
   (with-inline-assembly (:returns :eax)
-    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
+    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:testb 7 :al)
     (:jnz '(:sub-program ()
 	    (:int 107)))))
@@ -508,7 +535,7 @@
 (defun malloc-cons-pointer ()
   "Return current cons-pointer in 8-byte units since buffer-start."
   (with-inline-assembly (:returns :eax)
-    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
+    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:movl (:eax 4) :eax)
     (:testb 7 :al)
     (:jnz '(:sub-program ()
@@ -524,7 +551,7 @@
   "Allocate a cons cell. Call with car in eax and cdr in ebx."
   (with-inline-assembly (:returns :multiple-values)
     (:xchgl :eax :ecx)
-    (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
+    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:movl (:eax 4) :edx)
     (:addl 8 :edx)
     (:cmpl :edx (:eax))
@@ -570,14 +597,14 @@
 	    (:ret)
 	   not-fixnum
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) ; Save value for later
-	    (:call-global-constant malloc)
+	    (:movl ,(* 2 movitz:+movitz-fixnum-factor+) :eax)
+	    (:call-local-pf malloc-non-pointer-words)
 	    (:movl ,(dpb movitz:+movitz-fixnum-factor+
 			 (byte 16 16)
 			 (movitz:tag :bignum 0))
-		   (:eax))
+		   (:eax ,movitz:+other-type-offset+))
 	    (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) ; Restore value
-	    (:movl :ecx (:eax 4))
-	    (:leal (:eax 6) :eax)
+	    (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
 	    (:ret))))
     (do-it)))
 	    




From ffjeld at common-lisp.net  Thu Jul 15 21:07:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:27 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1BlDRv-0007df-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:27 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.8 movitz/losp/muerte/run-time-context.lisp:1.9
--- movitz/losp/muerte/run-time-context.lisp:1.8	Thu Jul 15 04:17:02 2004
+++ movitz/losp/muerte/run-time-context.lisp	Thu Jul 15 14:07:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.8 2004/07/15 11:17:02 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.9 2004/07/15 21:07:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -132,8 +132,7 @@
 (defun clone-run-time-context (&key (parent (current-run-time-context))
 				    (name :anonymous))
   (check-type parent run-time-context)
-  (let ((context (inline-malloc #.(bt:sizeof 'movitz::movitz-constant-block)
-				:other-tag :run-time-context)))
+  (let ((context (malloc-pointer-words #.(cl:truncate (bt:sizeof 'movitz::movitz-constant-block) 4))))
     (memcopy context parent -6 0 0 #.(bt:sizeof 'movitz::movitz-constant-block)
 	     :unsigned-byte8)
     (setf (%run-time-context-slot 'name context) name




From ffjeld at common-lisp.net  Thu Jul 15 21:07:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:32 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1BlDS0-0007hs-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:32 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.16 movitz/losp/muerte/symbols.lisp:1.17
--- movitz/losp/muerte/symbols.lisp:1.16	Tue Jul 13 07:06:56 2004
+++ movitz/losp/muerte/symbols.lisp	Thu Jul 15 14:07:32 2004
@@ -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.16 2004/07/13 14:06:56 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.17 2004/07/15 21:07:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,14 +28,14 @@
     (symbol
      (with-inline-assembly (:returns :eax)
        (:compile-form (:result-mode :eax) symbol)
-       (:call-global-constant dynamic-load)))))
+       (:call-local-pf dynamic-load)))))
 
 (defun %unbounded-symbol-value (symbol)
   "Return the symbol's value without checking if it's bound or not."
   (check-type symbol symbol)
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) symbol)
-    (:call-global-constant dynamic-find-binding)
+    (:call-local-pf dynamic-find-binding)
     (:jnc 'no-local-binding)
     (:movl (:eax) :eax)
     (:jmp 'done)
@@ -51,7 +51,7 @@
      (with-inline-assembly (:returns :ebx)
        (:compile-form (:result-mode :eax) symbol)
        (:compile-form (:result-mode :ebx) value)
-       (:call-global-constant dynamic-store)))))
+       (:call-local-pf dynamic-store)))))
 
 (defun set (symbol value)
   (setf (symbol-value symbol) value))
@@ -147,7 +147,7 @@
 				      (flags 0))
   (eval-when (:compile-toplevel)
     (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
-  (let ((symbol (%word-offset (malloc-clumps 3) 1)))
+  (let ((symbol (%word-offset (malloc-pointer-words 6) 1)))
     (setf-movitz-accessor (symbol movitz-symbol package) package)
     (setf-movitz-accessor (symbol movitz-symbol name) name)
     (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key)
@@ -170,7 +170,7 @@
   (if (or (eq nil symbol)
 	  (not copy-properties))
       (%create-symbol (symbol-name symbol))
-    (let ((x (%word-offset (malloc-clumps 3) 1)))
+    (let ((x (%word-offset (malloc-pointer-words 6) 1)))
       (dotimes (i 6)
 	(setf (memref x #.(cl:- (movitz:tag :symbol)) i :lisp)
 	  (memref symbol #.(cl:- (movitz:tag :symbol)) i :lisp)))




From ffjeld at common-lisp.net  Thu Jul 15 21:07:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 14:07:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/memory.lisp 
Message-ID: <E1BlDS4-0007n7-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv29726

Modified Files:
	memory.lisp 
Log Message:
This rather substantial check-in is a clean-up of all things related
to dynamic memory allocation. In particular, the separation between
the muerte kernel with its 'default' memory management (which simply
allocates objects consecutively until it runs out) and the los0 GC
implementation is improved.

Date: Thu Jul 15 14:07:36 2004
Author: ffjeld

Index: movitz/losp/x86-pc/memory.lisp
diff -u movitz/losp/x86-pc/memory.lisp:1.3 movitz/losp/x86-pc/memory.lisp:1.4
--- movitz/losp/x86-pc/memory.lisp:1.3	Mon Jan 19 03:23:52 2004
+++ movitz/losp/x86-pc/memory.lisp	Thu Jul 15 14:07:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Oct 11 16:32:11 2001
 ;;;;                
-;;;; $Id: memory.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $
+;;;; $Id: memory.lisp,v 1.4 2004/07/15 21:07:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,7 @@
 (in-package muerte.x86-pc)
 
 (defun memory-size ()
+  "Return memory size in megabytes."
   (let ((kilobyte-memsize
 	 (+ #x400
 	    (prog1
@@ -30,4 +31,4 @@
 		     (progn
 		       (setf (io-port #x70 :unsigned-byte8) #x17)
 		       (io-port #x71 :unsigned-byte8)))))))
-    (truncate kilobyte-memsize 1024)))
+    (values (truncate kilobyte-memsize 1024))))




From ffjeld at common-lisp.net  Fri Jul 16 00:02:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 17:02:04 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BlGAu-0007EW-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Added %make-bignum.

Date: Thu Jul 15 17:02:03 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.21 movitz/losp/muerte/inspect.lisp:1.22
--- movitz/losp/muerte/inspect.lisp:1.21	Thu Jul 15 14:07:04 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul 15 17:02:03 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.21 2004/07/15 21:07:04 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.22 2004/07/16 00:02:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -306,6 +306,16 @@
       (:movl :ecx (:eax :edx #.movitz:+other-type-offset+))
       (:subl 4 :edx)
       (:jnc 'copy-bignum-loop))))
+
+(defun %make-bignum (bigits)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:eax :ecx) (malloc-non-pointer-words (1+ bigits)) bigits)
+	    (:shll 16 :ecx)
+	    (:orl ,(movitz:tag :bignum 0) :ecx)
+	    (:movl :ecx (:eax ,movitz:+other-type-offset+)))))
+    (do-it)))
 
 (defun print-bignum (x)
   (check-type x bignum)




From ffjeld at common-lisp.net  Fri Jul 16 00:03:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 17:03:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlGBt-0000m0-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved ash. Fixed a bug wrt. carry-propagation in - for bignums.

Date: Thu Jul 15 17:03:05 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.66 movitz/losp/muerte/integers.lisp:1.67
--- movitz/losp/muerte/integers.lisp:1.66	Thu Jul 15 14:07:08 2004
+++ movitz/losp/muerte/integers.lisp	Thu Jul 15 17:03:05 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.66 2004/07/15 21:07:08 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -516,8 +516,11 @@
 			(:jne 'sub-loop)
 			(:subl :ecx
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:jc '(:sub-program (should-not-happen)
-			       (:int 107)))
+			(:jnc 'bignum-sub-done)
+		       propagate-carry
+			(:addl 4 :edx)
+			(:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jc 'propagate-carry)
 		       bignum-sub-done
 			)))))
 		(((integer 0 *) (integer * -1))
@@ -1088,14 +1091,63 @@
   
 (defun ash (integer count)
   (cond
-   ((not (minusp count))
-    (do () ((< count 16))
-      (setf integer (no-macro-call * #x10000 integer))
-      (decf count 16))
-    (dotimes (i count integer)
-      (setf integer (no-macro-call * 2 integer))))
-   (t (dotimes (i (- count) integer)
-	(setf integer (truncate integer 2))))))
+   ((= 0 count)
+    integer)
+   ((plusp count)
+    (let ((result-length (+ (integer-length integer) count)))
+      (cond
+       ((<= result-length 29)
+	(with-inline-assembly (:returns :eax)
+	  (:compile-two-forms (:eax :ecx) integer count)
+	  (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
+	  (:shll :cl :eax)))
+       (t (check-type integer (integer 0 *))
+	  (multiple-value-bind (long short)
+	      (truncate count 16)
+	    (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
+	      (dotimes (i long)
+		(setf (memref result -2 i :unsigned-byte16) 0))
+	      (etypecase integer
+		(fixnum
+		 (when (>= integer #x10000)
+		   (setf (memref result -2 (1+ long) :unsigned-byte16)
+		     (ldb (byte 16 16) integer)))
+		 (setf (memref result -2 long :unsigned-byte16)
+		   (ldb (byte 16 0) integer)))
+		(bignum
+		 (dotimes (i (* 2 (%bignum-bigits integer)))
+		   (setf (memref result -2 (+ i long) :unsigned-byte16)
+		     (memref integer -2 i :unsigned-byte16)))))
+	      (setf result (%bignum-canonicalize result))
+	      (dotimes (i short)
+		(setf result (* 2 result)))
+	      result))))))
+   (t (let ((count (- count)))
+	(etypecase integer
+	  (fixnum
+	   (with-inline-assembly (:returns :eax :type fixnum)
+	     (:compile-two-forms (:eax :ecx) integer count)
+	     (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
+	     (:std)
+	     (:sarl :cl :eax)
+	     (:andl -4 :eax)
+	     (:cld)))
+	  (positive-bignum
+	   (let* ((result-length (- (integer-length integer) count))
+		  (result (%make-bignum (truncate (+ result-length 31) 32))))
+	     (multiple-value-bind (long short)
+		 (truncate count 16)
+	       (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
+		 (dotimes (i (* 2 (%bignum-bigits result)))
+		   (let ((src (+ i long)))
+		     (setf (memref result -2 i :unsigned-byte16)
+		       (if (< src src-max-bigit)
+			   (memref integer -2 src :unsigned-byte16)
+			 0)))))
+	       (setf result (%bignum-canonicalize result))
+	       (dotimes (i short result)
+		 (setf result (truncate result 2)))
+	       result))))))))
 
 ;;;;
 
@@ -1317,10 +1369,16 @@
 		   ;; X is the biggest factor.
 		   (let ((r 0) (f 0))
 		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
-		       (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
-					  f)))
+		       (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
+				    f))
 		       (incf f 16))
-		     r))))))
+		     r)))
+		((t (integer * -1))
+		 (%negatef (* x (- y)) x y))
+		(((integer * -1) t)
+		 (%negatef (* (- x) y) x y))
+		(((integer * -1) (integer * -1))
+		 (* (- x) (- y))))))
 	(do-it)))
    (t (&rest factors)
       (declare (dynamic-extent factors))
@@ -1461,18 +1519,15 @@
 	       (setf msb (+ (* #x10000 msb)
 			    (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8))
 			    (memref divisor -2 msb-pos :unsigned-byte8)))
-	       (multiple-value-bind (long-shift short-shift)
-		   ;; This shifting stuff should be replaced by ash,
-		   ;; when ash is properly implemented.
-		   (truncate msb-pos 3)
+	       (let ((guess-shift (- (* msb-pos 8))))
 		 (do ((msb+1 (1+ msb))
 		      (q 0) (r number))
 		     ((< r divisor) (values q r))
-		   (let ((guess (truncate r msb+1)))
-		     (dotimes (i long-shift)
-		       (setf guess (truncate guess #x1000000)))
-		     (dotimes (i short-shift)
-		       (setf guess (truncate guess #x100)))
+		   (let ((guess (ash (truncate r msb+1) guess-shift)))
+;;;		     (dotimes (i long-shift)
+;;;		       (setf guess (truncate guess #x1000000)))
+;;;		     (dotimes (i short-shift)
+;;;		       (setf guess (truncate guess #x100)))
 		     (if (= 0 guess)
 			 (setf q (1+ q)
 			       r (- r divisor))




From ffjeld at common-lisp.net  Fri Jul 16 00:03:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 15 Jul 2004 17:03:43 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BlGCV-0001WJ-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
*** empty log message ***
Date: Thu Jul 15 17:03:43 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.75 movitz/compiler.lisp:1.76
--- movitz/compiler.lisp:1.75	Tue Jul 13 15:41:06 2004
+++ movitz/compiler.lisp	Thu Jul 15 17:03:42 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.75 2004/07/13 22:41:06 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.76 2004/07/16 00:03:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2347,6 +2347,9 @@
    (shadowing-variable
     :initarg :shadowing-variable
     :reader shadowing-variable)))
+
+(defmethod binding-store-type ((binding dynamic-binding))
+  (multiple-value-list (type-specifier-encode t)))
 
 (defun stack-frame-offset (stack-frame-position)
   (* -4 (1+ stack-frame-position)))




From ffjeld at common-lisp.net  Fri Jul 16 10:06:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 03:06:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BlPbw-0004ID-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Fixed a bug in the compiler-macro for (setf memref <negative> <x> :unsigned-byte32).

Date: Fri Jul 16 03:06:36 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.16 movitz/losp/muerte/memref.lisp:1.17
--- movitz/losp/muerte/memref.lisp:1.16	Thu Jul 15 14:07:18 2004
+++ movitz/losp/muerte/memref.lisp	Fri Jul 16 03:06:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.16 2004/07/15 21:07:18 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.17 2004/07/16 10:06:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -352,7 +352,7 @@
 		  (:compile-two-forms (:eax :edx) ,index-var ,offset-var)
 		  (:load-lexical (:lexical-binding ,object-var) :ebx)
 		  (:std)
-		  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+		  (:sarl ,movitz::+movitz-fixnum-shift+ :edx)
 		  (:addl :eax :edx) ; EDX = offset+index
 		  (:movl :ecx (:ebx :edx))
 		  (:movl :edi :edx)




From ffjeld at common-lisp.net  Fri Jul 16 10:42:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 03:42:41 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlQAr-0003Fo-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed a nasty bug in ash which failed to handle the situation when a
bignum got shifted to zero. Also fixed a bug in truncate on negatives.

Date: Fri Jul 16 03:42:41 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.67 movitz/losp/muerte/integers.lisp:1.68
--- movitz/losp/muerte/integers.lisp:1.67	Thu Jul 15 17:03:05 2004
+++ movitz/losp/muerte/integers.lisp	Fri Jul 16 03:42:40 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.68 2004/07/16 10:42:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1133,21 +1133,23 @@
 	     (:andl -4 :eax)
 	     (:cld)))
 	  (positive-bignum
-	   (let* ((result-length (- (integer-length integer) count))
-		  (result (%make-bignum (truncate (+ result-length 31) 32))))
-	     (multiple-value-bind (long short)
-		 (truncate count 16)
-	       (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
-		 (dotimes (i (* 2 (%bignum-bigits result)))
-		   (let ((src (+ i long)))
-		     (setf (memref result -2 i :unsigned-byte16)
-		       (if (< src src-max-bigit)
-			   (memref integer -2 src :unsigned-byte16)
-			 0)))))
-	       (setf result (%bignum-canonicalize result))
-	       (dotimes (i short result)
-		 (setf result (truncate result 2)))
-	       result))))))))
+	   (let ((result-length (- (integer-length integer) count)))
+	     (if (<= result-length 0)
+		 0
+	       (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
+		 (multiple-value-bind (long short)
+		     (truncate count 16)
+		   (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
+		     (dotimes (i (* 2 (%bignum-bigits result)))
+		       (let ((src (+ i long)))
+			 (setf (memref result -2 i :unsigned-byte16)
+			   (if (< src src-max-bigit)
+			       (memref integer -2 src :unsigned-byte16)
+			     0)))))
+		   (setf result (%bignum-canonicalize result))
+		   (dotimes (i short result)
+		     (setf result (truncate result 2)))
+		   result))))))))))
 
 ;;;;
 
@@ -1540,12 +1542,12 @@
 		   (%negatef r number divisor))))
 	(((integer 0 *) (integer * -1))
 	 (multiple-value-bind (q r)
-	     (truncate (- number) divisor)
+	     (truncate number (- divisor))
 	   (values (%negatef q number divisor)
 		   r)))
 	(((integer * -1) (integer * -1))
 	 (multiple-value-bind (q r)
-	     (truncate (- number) divisor)
+	     (truncate (- number) (- divisor))
 	   (values q (%negatef r number divisor))))
 	))))
 




From ffjeld at common-lisp.net  Fri Jul 16 10:43:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 03:43:27 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BlQBb-0003t3-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Do a bit more safety checking in %bignum-canonicalize and %make-bignum.

Date: Fri Jul 16 03:43:26 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.22 movitz/losp/muerte/inspect.lisp:1.23
--- movitz/losp/muerte/inspect.lisp:1.22	Thu Jul 15 17:02:03 2004
+++ movitz/losp/muerte/inspect.lisp	Fri Jul 16 03:43:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.22 2004/07/16 00:02:03 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.23 2004/07/16 10:43:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -265,12 +265,15 @@
   "Assuming x is a bignum, return the canonical integer value. That is,
 either return a fixnum, or destructively modify the bignum's length so
 that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
+  (check-type x bignum)
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :eax)
 	    (:load-lexical (:lexical-binding x) :eax)
 	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 	    (:shrl 16 :ecx)
+	    (:jz '(:sub-program (should-never-happen)
+		   (:int 107)))
 	   shrink-loop
 	    (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
 	    (:je 'shrink-no-more)
@@ -308,6 +311,7 @@
       (:jnc 'copy-bignum-loop))))
 
 (defun %make-bignum (bigits)
+  (assert (plusp bigits))
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :eax)




From ffjeld at common-lisp.net  Sat Jul 17 01:48:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:48:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BleJ6-0004vY-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed bugs in ash, truncate, *, and integer-length.

Date: Fri Jul 16 18:48:08 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.68 movitz/losp/muerte/integers.lisp:1.69
--- movitz/losp/muerte/integers.lisp:1.68	Fri Jul 16 03:42:40 2004
+++ movitz/losp/muerte/integers.lisp	Fri Jul 16 18:48:08 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.68 2004/07/16 10:42:40 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.69 2004/07/17 01:48:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1102,26 +1102,19 @@
 	  (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
 	  (:shll :cl :eax)))
        (t (check-type integer (integer 0 *))
-	  (multiple-value-bind (long short)
-	      (truncate count 16)
-	    (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
-	      (dotimes (i long)
-		(setf (memref result -2 i :unsigned-byte16) 0))
-	      (etypecase integer
-		(fixnum
-		 (when (>= integer #x10000)
-		   (setf (memref result -2 (1+ long) :unsigned-byte16)
-		     (ldb (byte 16 16) integer)))
-		 (setf (memref result -2 long :unsigned-byte16)
-		   (ldb (byte 16 0) integer)))
-		(bignum
-		 (dotimes (i (* 2 (%bignum-bigits integer)))
-		   (setf (memref result -2 (+ i long) :unsigned-byte16)
-		     (memref integer -2 i :unsigned-byte16)))))
-	      (setf result (%bignum-canonicalize result))
-	      (dotimes (i short)
-		(setf result (* 2 result)))
-	      result))))))
+	  (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
+	    (dotimes (i (* 2 (%bignum-bigits result)))
+	      (setf (memref result -2 i :unsigned-byte16)
+		(let ((pos (- (* i 16) count)))
+		  (cond
+		   ((minusp (+ pos 16)) 0)
+		   ((<= 0 pos)
+		    (ldb (byte 16 pos) integer))
+		   (t (ash (ldb (byte (+ pos 16) 0) integer)
+			   (- pos)))))))
+	    (assert (or (plusp (memref result -2 (+ -1 (* 2 (%bignum-bigits result))) :unsigned-byte16))
+			(plusp (memref result -2 (+ -2 (* 2 (%bignum-bigits result))) :unsigned-byte16))))
+	    (%bignum-canonicalize result))))))
    (t (let ((count (- count)))
 	(etypecase integer
 	  (fixnum
@@ -1134,22 +1127,42 @@
 	     (:cld)))
 	  (positive-bignum
 	   (let ((result-length (- (integer-length integer) count)))
-	     (if (<= result-length 0)
-		 0
-	       (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
-		 (multiple-value-bind (long short)
+	     (cond
+	      ((<= result-length 1)
+	       result-length)		; 1 or 0.
+	      (t (multiple-value-bind (long short)
 		     (truncate count 16)
-		   (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
-		     (dotimes (i (* 2 (%bignum-bigits result)))
-		       (let ((src (+ i long)))
-			 (setf (memref result -2 i :unsigned-byte16)
-			   (if (< src src-max-bigit)
-			       (memref integer -2 src :unsigned-byte16)
-			     0)))))
-		   (setf result (%bignum-canonicalize result))
-		   (dotimes (i short result)
-		     (setf result (truncate result 2)))
-		   result))))))))))
+		   (let ((result (%make-bignum (1+ (truncate (+ result-length 31) 32)))))
+		     (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
+		       (dotimes (i (* 2 (%bignum-bigits result)))
+			 (let ((src (+ i long)))
+			   (setf (memref result -2 i :unsigned-byte16)
+			     (if (< src src-max-bigit)
+				 (memref integer -2 src :unsigned-byte16)
+			       0)))))
+		     (%bignum-canonicalize
+		      (macrolet
+			  ((do-it ()
+			     `(with-inline-assembly (:returns :ebx)
+				(:compile-two-forms (:ecx :ebx) short result)
+				(:xorl :edx :edx) ; counter
+				(:xorl :eax :eax) ; We need to use EAX for u32 storage.
+				(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+				(:std)
+			       shift-short-loop
+				(:addl 4 :edx)
+				(:cmpw :dx (:ebx (:offset movitz-bignum length)))
+				(:jbe 'end-shift-short-loop)
+				(:movl (:ebx :edx (:offset movitz-bignum bigit0))
+				       :eax)
+				(:shrdl :cl :eax
+					(:ebx :edx (:offset movitz-bignum bigit0 -4)))
+				(:jmp 'shift-short-loop)
+			       end-shift-short-loop
+				(:movl :edx :eax) ; Safe EAX
+				(:shrl :cl (:ebx :edx (:offset movitz-bignum bigit0 -4)))
+				(:cld))))
+			(do-it))))))))))))))
 
 ;;;;
 
@@ -1211,7 +1224,7 @@
 	     (case f1
 	       (0 `(progn ,factor2 0))
 	       (1 factor2)
-;;;	       (2 `(let ((x ,factor2)) (+ x x)))
+	       (2 `(let ((x ,factor2)) (+ x x)))
 	       (t `(no-macro-call * ,factor1 ,factor2)))))
 	  (t `(no-macro-call * ,factor1 ,factor2)))))
     (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))
@@ -1371,8 +1384,9 @@
 		   ;; X is the biggest factor.
 		   (let ((r 0) (f 0))
 		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
-		       (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
-				    f))
+		       (let* ((digit (* x (memref y -2 half-bigit :unsigned-byte16)))
+			      (delta1 (ash digit f)))
+			 (incf r delta1))
 		       (incf f 16))
 		     r)))
 		((t (integer * -1))
@@ -1512,29 +1526,27 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (let* ((msb-pos (1- (* 4 (%bignum-bigits divisor))))
-		    (msb (memref divisor -2 msb-pos :unsigned-byte8)))
-	       (do () ((not (eq 0 msb)))
-		 (decf msb-pos)
-		 (setf msb (memref divisor -2 msb-pos :unsigned-byte8)))
-	       (decf msb-pos 2)
-	       (setf msb (+ (* #x10000 msb)
-			    (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8))
-			    (memref divisor -2 msb-pos :unsigned-byte8)))
-	       (let ((guess-shift (- (* msb-pos 8))))
-		 (do ((msb+1 (1+ msb))
-		      (q 0) (r number))
-		     ((< r divisor) (values q r))
-		   (let ((guess (ash (truncate r msb+1) guess-shift)))
-;;;		     (dotimes (i long-shift)
-;;;		       (setf guess (truncate guess #x1000000)))
-;;;		     (dotimes (i short-shift)
-;;;		       (setf guess (truncate guess #x100)))
+	  (t (let* ((guess-pos (- (integer-length divisor) 29))
+		    (msb (ldb (byte 29 guess-pos) divisor))) 
+	       (when (eq msb most-positive-fixnum)
+		 (decf guess-pos)
+		 (setf msb (ash msb -1)))
+	       (incf msb)
+	       (do ((q 0)
+		    (r number))
+		   ((< r divisor)
+		    (assert (and (not (minusp r)) (not (minusp q))) ()
+		      "(trunc ~S ~S) r: ~S q: ~S" number divisor r q)
+;;;		    (assert (= number (+ r (* q divisor))) ()
+;;;		      "trunc failed: q: ~S R: ~S" q r)
+		    (values q r))
+		 (let* ((guess (ash (truncate r msb) (- guess-pos))))
+		   (let ((delta (* guess divisor)))
 		     (if (= 0 guess)
 			 (setf q (1+ q)
 			       r (- r divisor))
 		       (setf q (+ q guess)
-			     r (- r (* divisor guess)))))))))))
+			     r (- r delta))))))))))
 	(((integer * -1) (integer 0 *))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)
@@ -1562,7 +1574,7 @@
       (if (= 0 r)
 	  q
 	(error "Don't know how to divide ~S by ~S." number (first denominators)))))
-   (t (reduce '/ denominators :initial-value number))))
+   (t (/ number (reduce '* denominators)))))
 	       
 (defun round (number &optional (divisor 1))
   "Mathematical rounding."
@@ -2010,6 +2022,7 @@
        (do-it)))
     (positive-bignum
      (cond
+      ((= size 0) 0)
       ((<= size 32)
        ;; The result is likely to be a fixnum (or at least an u32), due to byte-size.
        (macrolet




From ffjeld at common-lisp.net  Sat Jul 17 01:49:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:49:23 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BleKJ-0000bf-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Added assembly-macro :offset.

Date: Fri Jul 16 18:49:23 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.28 movitz/special-operators.lisp:1.29
--- movitz/special-operators.lisp:1.28	Thu Jul 15 14:06:28 2004
+++ movitz/special-operators.lisp	Fri Jul 16 18:49:23 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.28 2004/07/15 21:06:28 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.29 2004/07/17 01:49:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -521,6 +521,16 @@
 				   (setq side-effects t))
 				 (setf modifies (modifies-union modifies sub-modifies))
 				 sub-code))))
+		       (setf (assembly-macro-expander :offset amenv)
+			 #'(lambda (expr)
+			     (destructuring-bind (type slot &optional (extra 0))
+				 (cdr expr)
+			       (let ((mtype (find-symbol (symbol-name type) :movitz))
+				     (mslot (find-symbol (symbol-name slot) :movitz)))
+				 (assert mtype (mtype) "Type not a Movitz symbol: ~A" type)
+				 (assert mslot (mslot) "Slot not a Movitz symbol: ~A" slot)
+				 (list (+ (slot-offset mtype mslot)
+					  (eval extra)))))))
 		       (setf (assembly-macro-expander :returns-mode amenv)
 			 #'(lambda (expr)
 			     (assert (= 1 (length expr)))




From ffjeld at common-lisp.net  Sat Jul 17 01:52:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:52:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BleNK-0006X3-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Minor edits.

Date: Fri Jul 16 18:52:29 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.23 movitz/losp/muerte/inspect.lisp:1.24
--- movitz/losp/muerte/inspect.lisp:1.23	Fri Jul 16 03:43:26 2004
+++ movitz/losp/muerte/inspect.lisp	Fri Jul 16 18:52:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.23 2004/07/16 10:43:26 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.24 2004/07/17 01:52:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -275,11 +275,11 @@
 	    (:jz '(:sub-program (should-never-happen)
 		   (:int 107)))
 	   shrink-loop
-	    (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
+	    (:cmpl 4 :ecx)
 	    (:je 'shrink-no-more)
 	    (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
 	    (:jnz 'shrink-done)
-	    (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
+	    (:subl 4 :ecx)
 	    (:jmp 'shrink-loop)
 	   shrink-no-more
 	    (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+)
@@ -291,7 +291,9 @@
 		   (:jmp 'done)))
 	   shrink-done
 	    (:testb 3 :cl)
-	    (:jnz '(:sub-program () (:int 59)))
+	    (:jnz '(:sub-program () (:int 107)))
+	    (:testw :cx :cx)
+	    (:jz '(:sub-program () (:int 107)))
 	    (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
 	   done
 	    )))




From ffjeld at common-lisp.net  Sat Jul 17 01:53:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:53:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BleO5-00071l-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Fixed some bugs wrt. argument evaluation order.

Date: Fri Jul 16 18:53:17 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.17 movitz/losp/muerte/memref.lisp:1.18
--- movitz/losp/muerte/memref.lisp:1.17	Fri Jul 16 03:06:36 2004
+++ movitz/losp/muerte/memref.lisp	Fri Jul 16 18:53:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.17 2004/07/16 10:06:36 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.18 2004/07/17 01:53:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -92,14 +92,23 @@
 		      (:compile-form (:result-mode :eax) ,object)
 		      (:movzxw (:eax ,(offset-by 2)) :ecx)))
 		  ((eq 0 offset)
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-		      (:compile-two-forms (:eax :ecx) ,object ,index)
-		      (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-		      (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))
-		  (t (let ((object-var (gensym "memref-object-")))
-		       `(let ((,object-var ,object))
+		   (let ((object-var (gensym "memref-object-"))
+			 (index-var (gensym "memref-index-")))
+		     `(let ((,object-var ,object)
+			    (,index-var ,index))
+			(with-inline-assembly (:returns :untagged-fixnum-ecx
+							:type (unsiged-byte 16))
+			  (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
+			  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+			  (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))
+		  (t (let ((object-var (gensym "memref-object-"))
+			   (offset-var (gensym "memref-offset-"))
+			   (index-var (gensym "memref-index-")))
+		       `(let ((,object-var ,object)
+			      (,offset-var ,offset)
+			      (,index-var ,index))
 			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
-			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var)
 			    (:leal (:ecx (:ebx 2)) :ecx)
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
 			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
@@ -378,40 +387,55 @@
 				 (* 2 (movitz:movitz-eval index env)))))))
 	((and (movitz:movitz-constantp offset env)
 	      (movitz:movitz-constantp value env))
-	 (let ((value (movitz:movitz-eval value env)))
+	 (let ((value (movitz:movitz-eval value env))
+	       (index-var (gensym "memref-index-"))
+	       (object-var (gensym "memref-object-")))
 	   (check-type value (unsigned-byte 16))
-	   `(progn
+	   `(let ((,object-var ,object)
+		  (,index-var ,index))
 	      (with-inline-assembly (:returns :nothing)
-		(:compile-two-forms (:ecx :ebx) ,index ,object)
+		(:compile-two-forms (:ecx :ebx) ,index-var ,object-var)
 		(:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
 		(:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
 	      ,value)))
 	((movitz:movitz-constantp offset env)
-	 (let ((value-var (gensym "memref-value-")))
+	 (let ((value-var (gensym "memref-value-"))
+	       (index-var (gensym "memref-index-"))
+	       (object-var (gensym "memref-object-")))
 	   (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
-	       `(let ((,value-var ,value))
+	       `(let ((,value-var ,value)
+		      (,object-var ,object)
+		      (,index-var ,index))
 		  (with-inline-assembly (:returns :untagged-fixnum-eax)
-		    (:compile-two-forms (:ebx :ecx) ,object ,index)
+		    (:compile-two-forms (:ebx :ecx) ,object-var ,index-var)
 		    (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax)
 		    (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
 		    (:movw :ax (:ebx :ecx  ,(movitz:movitz-eval offset env)))))
-	     `(let ((,value-var ,value))
+	     `(let ((,value-var ,value)
+		    (,object-var ,object)
+		    (,index-var ,index))
 		(with-inline-assembly (:returns :nothing)
-		  (:compile-two-forms (:ebx :ecx) ,object ,index)
+		  (:compile-two-forms (:ebx :ecx) ,object-var ,index-var)
 		  (:load-lexical (:lexical-binding ,value-var) :eax)
 		  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-		  (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
-		  (:movb :ah (:ebx :ecx  ,(movitz:movitz-eval offset env)))
-		  (:andl #xff0000 :eax)
-		  (:shrl 8 :eax)
-		  (:movb :ah (:ebx :ecx ,(1+ (movitz:movitz-eval offset env)))))
+		  (:movl :edi :edx)
+		  (:std)
+		  (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
+		  (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env)))
+		  (:movl :edi :eax)
+		  (:cld))
 		,value-var))))
 	(t (let ((value-var (gensym "memref-value-"))
-		 (object-var (gensym "memref-object-")))
+		 (object-var (gensym "memref-object-"))
+		 (offset-var (gensym "memref-offset-"))
+		 (index-var (gensym "memref-index-")))
 	     (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
-		 `(let ((,value-var ,offset) (,object-var ,object))
+		 `(let ((,value-var ,value)
+			(,object-var ,object)
+			(,offset-var ,offset)
+			(,index-var ,index))
 		    (with-inline-assembly (:returns :untagged-fixnum-eax)
-		      (:compile-two-forms (:ebx :ecx) ,offset ,index)
+		      (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var)
 		      (:load-lexical (:lexical-binding ,value-var) :eax)
 		      (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax)
 		      (:leal (:ebx (:ecx 2)) :ecx)
@@ -419,9 +443,12 @@
 		      (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		      (:load-lexical (:lexical-binding ,object-var) :ebx)
 		      (:movw :ax (:ebx :ecx))))
-	       `(let ((,value-var ,value) (,object-var ,object))
+	       `(let ((,value-var ,value)
+		      (,object-var ,object)
+		      (,offset-var ,offset)
+		      (,index-var ,index))
 		  (with-inline-assembly (:returns :nothing)
-		    (:compile-two-forms (:ebx :ecx) ,offset ,index)
+		    (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var)
 		    (:load-lexical (:lexical-binding ,value-var) :eax)
 		    (:leal (:ebx (:ecx 2)) :ecx)
 		    (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)




From ffjeld at common-lisp.net  Sat Jul 17 01:54:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:54:12 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BleOy-0002fm-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
This malloc-cons-pointer sort of works with los0-gc.

Date: Fri Jul 16 18:54:12 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.29 movitz/losp/muerte/primitive-functions.lisp:1.30
--- movitz/losp/muerte/primitive-functions.lisp:1.29	Thu Jul 15 14:07:22 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Fri Jul 16 18:54:12 2004
@@ -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.29 2004/07/15 21:07:22 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.30 2004/07/17 01:54:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -534,6 +534,10 @@
   
 (defun malloc-cons-pointer ()
   "Return current cons-pointer in 8-byte units since buffer-start."
+  (let ((x (%run-time-context-slot 'nursery-space)))
+    (when (typep x 'vector)
+      (truncate (aref x 0) 8)))
+  #+ignore
   (with-inline-assembly (:returns :eax)
     (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:movl (:eax 4) :eax)




From ffjeld at common-lisp.net  Sat Jul 17 01:54:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:54:55 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <E1BlePf-0003U2-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Minor fix regarding display of memory usage in time macro.

Date: Fri Jul 16 18:54:55 2004
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.7 movitz/losp/muerte/environment.lisp:1.8
--- movitz/losp/muerte/environment.lisp:1.7	Fri Apr 23 08:02:59 2004
+++ movitz/losp/muerte/environment.lisp	Fri Jul 16 18:54:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.7 2004/04/23 15:02:59 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.8 2004/07/17 01:54:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -138,13 +138,13 @@
 				    (constantly-true 123)
 				    (time-skew-measure start-mem x-lo x-hi))
 			   finally (return x)))))
-	   (clumps (- (malloc-cons-pointer) start-mem))
+	   (clumps (and start-mem (- (malloc-cons-pointer) start-mem)))
 	   (delta-hi (- end-time-hi start-time-hi))
 	   (delta-lo (- end-time-lo start-time-lo skew)))
       (if (= 0 delta-hi)
-	  (format t "~&;; CPU cycles: ~D.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%"
+	  (format t "~&;; CPU cycles: ~D.~@[~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
 		  delta-lo clumps clumps)
-	(format t "~&;; CPU cycles: ~DM.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%"
+	(format t "~&;; CPU cycles: ~DM.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
 		(+ (ash delta-hi 9) (ash delta-lo -20)) clumps clumps)))))
 
 (defmacro time (form)




From ffjeld at common-lisp.net  Sat Jul 17 01:56:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 16 Jul 2004 18:56:53 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BleRZ-0001WF-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Some cosmetics on gc.

Date: Fri Jul 16 18:56:52 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.28 movitz/losp/los0-gc.lisp:1.29
--- movitz/losp/los0-gc.lisp:1.28	Thu Jul 15 14:06:33 2004
+++ movitz/losp/los0-gc.lisp	Fri Jul 16 18:56:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.28 2004/07/15 21:06:33 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.29 2004/07/17 01:56:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,7 @@
 (in-package muerte.init)
 
 (defvar *gc-quiet* nil)
+(defvar *gc-running* nil)
     
 (defun make-space (location size)
   "Make a space vector at a fixed location."
@@ -246,15 +247,19 @@
   (setf (exception-handler 113)
     (lambda (exception interrupt-frame)
       (declare (ignore exception interrupt-frame))
-      (unless *gc-quiet*
-	(format t "~&;; GC.. "))
-      (stop-and-copy)
-      (loop				; This is  a nice opportunity to poll the keyboard..
-	(case (muerte.x86-pc.keyboard:poll-char)
-	  ((#\esc)
-	   (break "Los0 GC keyboard poll."))
-	  ((nil)
-	   (return))))))
+      (when *gc-running*
+	(let ((muerte::*error-no-condition-for-debugger* t))
+	  (error "Recursive GC triggered.")))
+      (let ((*gc-running t))
+	(unless *gc-quiet*
+	  (format t "~&;; GC.. "))
+	(stop-and-copy)
+	(loop				; This is  a nice opportunity to poll the keyboard..
+	  (case (muerte.x86-pc.keyboard:poll-char)
+	    ((#\esc)
+	     (break "Los0 GC keyboard poll."))
+	    ((nil)
+	     (return)))))))
   (let* ((actual-duo-space (or duo-space
 			       (allocate-duo-space (* kb-size #x100))))
 	 (last-location (object-location (cons 1 2))))
@@ -351,15 +356,14 @@
 		   (cond
 		    ((not (object-in-space-p oldspace x))
 		     x)
-		    #+ignore
-		    ((typep x 'muerte::tag6)
-		     (let ((fwi (position (object-location x) *x* :test #'eq)))
-		       (if fwi
-			   (muerte::%word-offset (aref *x* (1+ fwi)) 6)
-			 (let ((fw (shallow-copy x)))
-			   (vector-push (object-location x) *x*)
-			   (vector-push (object-location fw) *x*)
-			   fw))))
+		    #+ignore ((typep x 'muerte::bignum)
+			      (let ((fwi (position (object-location x) *x* :test #'eq)))
+				(if fwi
+				    (muerte::%word-offset (aref *x* (1+ fwi)) 6)
+				  (let ((fw (shallow-copy x)))
+				    (vector-push (object-location x) *x*)
+				    (vector-push (object-location fw) *x*)
+				    fw))))
 		    (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
 			 (if (object-in-space-p newspace forwarded-x)
 			     (progn
@@ -385,16 +389,15 @@
 			       (+ newspace-location (space-fresh-pointer newspace)))
 	       (setf scan-pointer fresh-pointer))
 
-	#+ignore
-	(dotimes (i (truncate (length *x*) 2))
-	  (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6))
-		(y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6)))
-	    (assert (and (object-in-space-p newspace y)
-			 (object-in-space-p oldspace x)
-			 (or (typep x 'muerte::std-instance)
-			     (equalp x y)))
-		()
-	      "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace)))
+	#+ignore (dotimes (i (truncate (length *x*) 2))
+		   (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6))
+			 (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6)))
+		     (assert (and (object-in-space-p newspace y)
+				  (object-in-space-p oldspace x)
+				  (or (typep x 'muerte::std-instance)
+				      (equalp x y)))
+			 ()
+		       "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace)))
 
 	;; GC completed, oldspace is evacuated.
 	(unless *gc-quiet*




From ffjeld at common-lisp.net  Sat Jul 17 11:27:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 04:27:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlnME-0004nq-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
This bignum multiply is twice as good in time, space, and read/portability.

Date: Sat Jul 17 04:27:58 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.69 movitz/losp/muerte/integers.lisp:1.70
--- movitz/losp/muerte/integers.lisp:1.69	Fri Jul 16 18:48:08 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 04:27:58 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.69 2004/07/17 01:48:08 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.70 2004/07/17 11:27:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -487,11 +487,7 @@
 		   0)
 		  ((< minuend subtrahend)
 		   (let ((x (- subtrahend minuend)))
-		     (when (typep x 'bignum)
-		       (setf (memref x ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)
-				     0 :unsigned-byte8)
-			 #xff))
-		     x))
+		     (%negatef x subtrahend minuend)))
 		  (t (%bignum-canonicalize
 		      (with-inline-assembly (:returns :eax)
 			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
@@ -1093,6 +1089,7 @@
   (cond
    ((= 0 count)
     integer)
+   ((= 0 integer) 0)
    ((plusp count)
     (let ((result-length (+ (integer-length integer) count)))
       (cond
@@ -1382,13 +1379,11 @@
 		 (if (< x y)
 		     (* y x)
 		   ;; X is the biggest factor.
-		   (let ((r 0) (f 0))
-		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
-		       (let* ((digit (* x (memref y -2 half-bigit :unsigned-byte16)))
-			      (delta1 (ash digit f)))
-			 (incf r delta1))
-		       (incf f 16))
-		     r)))
+		   (do ((r 0)
+			(length (integer-length y))
+			(i 0 (+ i 29)))
+		       ((>= i length) r)
+		     (incf r (ash (* x (ldb (byte 29 i) y)) i)))))
 		((t (integer * -1))
 		 (%negatef (* x (- y)) x y))
 		(((integer * -1) t)




From ffjeld at common-lisp.net  Sat Jul 17 12:16:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 05:16:03 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1Blo6l-0004nI-00@common-lisp.net>

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

Added Files:
	arithmetic-macros.lisp 
Log Message:
Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp.

Date: Sat Jul 17 05:16:03 2004
Author: ffjeld





From ffjeld at common-lisp.net  Sat Jul 17 12:16:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 05:16:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1Blo6q-0004wb-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp.

Date: Sat Jul 17 05:16:08 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.7 movitz/losp/muerte/common-lisp.lisp:1.8
--- movitz/losp/muerte/common-lisp.lisp:1.7	Fri Apr 23 08:00:14 2004
+++ movitz/losp/muerte/common-lisp.lisp	Sat Jul 17 05:16:08 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.7 2004/04/23 15:00:14 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.8 2004/07/17 12:16:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -17,6 +17,7 @@
 
 (require :muerte/setf)
 (require :muerte/more-macros)
+(require :muerte/arithmetic-macros)
 (require :muerte/memref)
 (require :muerte/basic-functions)
 (require :muerte/variables)




From ffjeld at common-lisp.net  Sat Jul 17 12:16:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 05:16:28 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1Blo7A-0005dQ-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Minor edit.

Date: Sat Jul 17 05:16:28 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.18 movitz/losp/muerte/memref.lisp:1.19
--- movitz/losp/muerte/memref.lisp:1.18	Fri Jul 16 18:53:17 2004
+++ movitz/losp/muerte/memref.lisp	Sat Jul 17 05:16:28 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.18 2004/07/17 01:53:17 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.19 2004/07/17 12:16:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -96,8 +96,7 @@
 			 (index-var (gensym "memref-index-")))
 		     `(let ((,object-var ,object)
 			    (,index-var ,index))
-			(with-inline-assembly (:returns :untagged-fixnum-ecx
-							:type (unsiged-byte 16))
+			(with-inline-assembly (:returns :untagged-fixnum-ecx)
 			  (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
 			  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
 			  (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))




From ffjeld at common-lisp.net  Sat Jul 17 12:17:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 05:17:35 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1Blo8F-0006Y8-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Added special operator compiler-macro-call, that really does nothing
except ensure that the operator is in fact a compiler-macro.

Date: Sat Jul 17 05:17:35 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.29 movitz/special-operators.lisp:1.30
--- movitz/special-operators.lisp:1.29	Fri Jul 16 18:49:23 2004
+++ movitz/special-operators.lisp	Sat Jul 17 05:17:35 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.29 2004/07/17 01:49:23 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.30 2004/07/17 12:17:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1051,6 +1051,15 @@
   (destructuring-bind (operator &rest arguments)
       (cdr form)
     (compiler-call #'compile-apply-symbol
+      :forward all
+      :form (cons operator arguments))))
+
+(define-special-operator muerte::compiler-macro-call (&all all &form form &env env)
+  (destructuring-bind (operator &rest arguments)
+      (cdr form)
+    (assert (movitz-compiler-macro-function operator env) ()
+      "There is no compiler-macro ~S." operator)
+    (compiler-call #'compile-compiler-macro-form
       :forward all
       :form (cons operator arguments))))
 




From ffjeld at common-lisp.net  Sat Jul 17 12:16:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 05:16:13 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Blo6v-0005B3-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp.

Date: Sat Jul 17 05:16:12 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.70 movitz/losp/muerte/integers.lisp:1.71
--- movitz/losp/muerte/integers.lisp:1.70	Sat Jul 17 04:27:58 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 05:16:12 2004
@@ -9,12 +9,13 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.70 2004/07/17 11:27:58 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.71 2004/07/17 12:16:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (require :muerte/basic-macros)
 (require :muerte/typep)
+(require :muerte/arithmetic-macros)
 (provide :muerte/integers)
 
 (in-package muerte)
@@ -22,113 +23,404 @@
 (defconstant most-positive-fixnum #.movitz::+movitz-most-positive-fixnum+)
 (defconstant most-negative-fixnum #.movitz::+movitz-most-negative-fixnum+)
 
-(deftype positive-fixnum ()
-  `(integer 0 ,movitz:+movitz-most-positive-fixnum+))
-
-(deftype positive-bignum ()
-  `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *))
-
-(deftype negative-fixnum ()
-  `(integer ,movitz:+movitz-most-negative-fixnum+ -1))
 
-(defmacro number-double-dispatch ((x y) &rest clauses)
-  `(let ((x ,x) (y ,y))
-     (cond ,@(loop for ((x-type y-type) . then-body) in clauses
-		 collect `((and (typep x ',x-type) (typep y ',y-type))
-			   , at then-body))
-	   (t (error "Not numbers: ~S or ~S." x y)))))
-
-(defun fixnump (x)
-  (typep x 'fixnum))
+;;; Comparison
 
-(define-compiler-macro evenp (x)
-  `(with-inline-assembly (:returns :boolean-zf=1)
-     (:compile-form (:result-mode :eax) ,x)
-     (:call-global-pf unbox-u32)
-     (:testb 1 :cl)))
+(define-primitive-function fast-compare-two-reals (n1 n2)
+  "Compare two numbers (i.e. set EFLAGS accordingly)."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :nothing) ; unspecified
+	    (:testb ,movitz::+movitz-fixnum-zmask+ :al)
+	    (:jnz 'n1-not-fixnum)
+	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
+	    (:jnz 'n2-not-fixnum-but-n1-is)
+	    (:cmpl :ebx :eax)		; both were fixnum
+	    (:ret)
+	   n1-not-fixnum		; but we don't know about n2
+	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
+	    (:jnz 'neither-is-fixnum)
+	    ;; n2 is fixnum
+	    (:locally (:jmp (:edi (:edi-offset fast-compare-real-fixnum))))
+	   n2-not-fixnum-but-n1-is
+	    (:locally (:jmp (:edi (:edi-offset fast-compare-fixnum-real))))
+	   neither-is-fixnum
+	    ;; Check that both numbers are bignums, and compare them.
+	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jnz '(:sub-program (n1-not-bignum)
+		    (:int 107)))
+	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+	    (:cmpb ,(movitz:tag :bignum) :cl)
+	    (:jne 'n1-not-bignum)
 
-(defun evenp (x)
-  (evenp x))
+	    (:cmpl :eax :ebx)		; If they are EQ, they are certainly =
+	    (:je '(:sub-program (n1-and-n2-are-eq)
+		   (:ret)))
 
-(define-compiler-macro oddp (x)
-  `(with-inline-assembly (:returns :boolean-zf=0)
-     (:compile-form (:result-mode :eax) ,x)
-     (:call-global-pf unbox-u32)
-     (:testb 1 :cl)))
+	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jnz '(:sub-program (n2-not-bignum)
+		    (:int 107)))
+	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
+	    (:cmpb ,(movitz:tag :bignum) :cl)
+	    (:jne 'n2-not-bignum)
 
-(defun oddp (x)
-  (oddp x))
+	    (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign)))
+	    (:jne '(:sub-program (different-signs)
+		    ;; Comparing the sign-bytes sets up EFLAGS correctly!
+		    (:ret)))
+	    (:testl #xff00 :ecx)
+	    (:jnz 'compare-negatives)
+	    ;; Both n1 and n2 are positive bignums.
 
-;;; Types
+	    (:shrl 16 :ecx)
+	    (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
+	    (:jne '(:sub-program (positive-different-sizes)
+		    (:ret)))
 
-(define-typep integer (x &optional (min '*) (max '*))
-  (and (typep x 'integer)
-       (or (eq min '*) (<= min x))
-       (or (eq max '*) (<= x max))))
+	    ;; Both n1 and n2 are positive bignums of the same size, namely ECX.
+	    (:movl :ecx :edx)		; counter
+	   positive-compare-loop
+	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+	    (:jz 'positive-compare-lsb)
+	    (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		   :ecx)
+	    (:cmpl :ecx
+		   (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:je 'positive-compare-loop)
+	   positive-compare-lsb
+	    ;; Now we have to make the compare act as unsigned, which is why
+	    ;; we compare zero-extended 16-bit quantities.
+	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)		; First compare upper 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)
+	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
+	    (:jne 'upper-16-decisive)
+	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
+	   upper-16-decisive
+	    (:ret)
+	    
+	   compare-negatives
+	    ;; Moth n1 and n2 are negative bignums.
 
-(deftype signed-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    'integer)
-   ((typep size '(integer 1 *))
-    (list 'integer
-	  (- (ash 1 (1- size)))
-	  (1- (ash 1 (1- size)))))
-   (t (error "Illegal size for signed-byte."))))
+	    (:shrl 16 :ecx)
+	    (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx)
+	    (:jne '(:sub-program (negative-different-sizes)
+		    (:ret)))
 
-(deftype unsigned-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    '(integer 0))
-   ((typep size '(integer 1 *))
-    (list 'integer 0 (1- (ash 1 size))))
-   (t (error "Illegal size for unsigned-byte."))))
+	    ;; Both n1 and n2 are negative bignums of the same size, namely ECX.
+	    (:movl :ecx :edx)		; counter
+	   negative-compare-loop
+	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+	    (:jz 'negative-compare-lsb)
+	    (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		   :ecx)
+	    (:cmpl :ecx
+		   (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:je 'negative-compare-loop)
+	    (:ret)
+	   negative-compare-lsb		; it's down to the LSB bigits.
+	    ;; Now we have to make the compare act as unsigned, which is why
+	    ;; we compare zero-extended 16-bit quantities.
+	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)		; First compare upper 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     :ecx)
+	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
+	    (:jne 'negative-upper-16-decisive)
+	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     :ecx)		; Then compare lower 16 bits.
+	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
+	   negative-upper-16-decisive
+	    (:ret))))
+    (do-it)))
 
-(define-simple-typep (bit bitp) (x)
-  (or (eq x 0) (eq x 1)))
+(define-primitive-function fast-eql (x y)
+  "Compare EAX and EBX under EQL, result in ZF.
+Preserve EAX and EBX."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :nothing) ; unspecified
+	    (:cmpl :eax :ebx)		; EQ?
+	    (:je 'done)
+	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jne 'done)
+	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jne 'done)
+	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+	    (:cmpb ,(movitz:tag :bignum) :cl)
+	    (:jne 'done)
+	    (:cmpl :ecx (:ebx ,movitz:+other-type-offset+))
+	    (:jne 'done)
+	    ;; Ok.. we have two bignums of identical sign and size.
+	    (:shrl 16 :ecx)
+	    (:movl :ecx :edx)		; counter
+	   compare-loop
+	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+	    (:jz 'done)
+	    (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		   :ecx)
+	    (:cmpl :ecx
+		   (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+	    (:je 'compare-loop)
+	   done
+	    (:ret))))
+    (do-it)))
 
-;;; 
+(define-primitive-function fast-compare-fixnum-real (n1 n2)
+  "Compare (known) fixnum <n1> with real <n2>."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :nothing) ; unspecified
+	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
+	    (:jnz 'n2-not-fixnum)
+	    (:cmpl :ebx :eax)
+	    (:ret)
+	   n2-not-fixnum
+	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jnz '(:sub-program (not-integer)
+		    (:int 107)
+		    (:jmp 'not-integer)))
+	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
+	    (:cmpw ,(movitz:tag :bignum 0) :cx)
+	    (:jne 'not-plusbignum)
+	    ;; compare eax with something bigger
+	    (:cmpl #x10000000 :edi)
+	    (:ret)
+	   not-plusbignum
+	    (:cmpw ,(movitz:tag :bignum #xff) :cx)
+	    (:jne 'not-integer)
+	    ;; compare ebx with something bigger
+	    (:cmpl #x-10000000 :edi)
+	    (:ret))))
+    (do-it)))
 
-(defun %negatef (x p0 p1)
-  "Negate x. If x is not eq to p0 or p1, negate x destructively."
-  (etypecase x
-    (fixnum (- x))
-    (bignum
-     (if (or (eq x p0) (eq x p1))
-	 (- x)
-       (with-inline-assembly (:returns :eax)
-	 (:compile-form (:result-mode :eax) x)
-	 (:xorl #xff00 (:eax #.movitz:+other-type-offset+)))))))
+(define-primitive-function fast-compare-real-fixnum (n1 n2)
+  "Compare real <n1> with fixnum <n2>."
+  (with-inline-assembly (:returns :nothing) ; unspecified
+    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
+    (:jnz 'not-fixnum)
+    (:cmpl :ebx :eax)
+    (:ret)
+   not-fixnum
+    (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
+    (:testb 7 :cl)
+    (:jnz '(:sub-program (not-integer)
+	    (:int 107)
+	    (:jmp 'not-integer)))
+    (:movl (:eax #.movitz:+other-type-offset+) :ecx)
+    (:cmpw #.(movitz:tag :bignum 0) :cx)
+    (:jne 'not-plusbignum)
+    ;; compare ebx with something bigger
+    (:cmpl #x-10000000 :edi)
+    (:ret)
+   not-plusbignum
+    (:cmpw #.(movitz:tag :bignum #xff) :cx)
+    (:jne 'not-integer)
+    ;; compare ebx with something bigger
+    (:cmpl #x10000000 :edi)
+    (:ret)))
 
-;;; Addition
+;;;
 
-(define-compiler-macro + (&whole form &rest operands &environment env)
-  (case (length operands)
-    (0 0)
-    (1 (first operands))
-    #+ignore (2 `(+%2op ,(first operands) ,(second operands)))
-    (2 `(let ((x ,(first operands))
-	      (y ,(second operands)))
-	  (++%2op x y)))
-    (t (let ((operands
-	      (loop for operand in operands
-		  if (movitz:movitz-constantp operand env)
-		  sum (movitz:movitz-eval operand env)
-		  into constant-term
-		  else collect operand
-		  into non-constant-operands
-		  finally (return (if (zerop constant-term)
-				      non-constant-operands
-				    (cons constant-term non-constant-operands))))))
-	 `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands))))))
 
-(defun + (&rest terms)
-  (declare (without-check-stack-limit))
-  (numargs-case
-   (1 (x) x)
-   (2 (x y)
-      (macrolet
-	  ((do-it ()
+(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
+  `(progn
+     ,(when condition
+	`(define-compiler-macro ,2op-name (n1 n2)
+	   (cond
+	    ((movitz:movitz-constantp n1)
+	     (let ((n1 (movitz::movitz-eval n1)))
+	       (check-type n1 (signed-byte 30))
+	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		  (:call-global-pf fast-compare-fixnum-real))))
+	    ((movitz:movitz-constantp n2)
+	     (let ((n2 (movitz::movitz-eval n2)))
+	       (check-type n2 (signed-byte 30))
+	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		  (:call-global-pf fast-compare-real-fixnum))))
+	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		  (:call-global-pf fast-compare-two-reals))))))
+
+     (defun ,2op-name (n1 n2)
+       (,2op-name n1 n2))
+
+     (define-compiler-macro ,name (&whole form number &rest more-numbers)
+       (case (length more-numbers)
+	 (0 `(progn ,number t))
+	 (1 `(,',2op-name ,number ,(first more-numbers)))
+	 ,@(when 3op-name
+	     `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers)))))
+	 (t #+ignore (when (= 2 (length more-numbers))
+		       (warn "3op: ~S" form))
+	  `(and (,',2op-name ,number ,(first more-numbers))
+		  (,',name , at more-numbers)))))
+
+     ,(when defun-p
+	`(defun ,name (number &rest more-numbers)
+	   (declare (dynamic-extent more-numbers))
+	   (cond
+	    ((null more-numbers)
+	     (check-type number fixnum)
+	     t)
+	    ((not (cdr more-numbers))
+	     (,2op-name number (first more-numbers)))
+	    (t (and (,2op-name number (first more-numbers))
+		    (do ((p more-numbers (cdr p)))
+			((not (cdr p)) t)
+		      (unless (,2op-name (car p) (cadr p))
+			(return nil))))))))))
+
+(define-number-relational >= >=%2op :boolean-greater-equal)
+(define-number-relational > >%2op :boolean-greater)
+(define-number-relational < <%2op :boolean-less)
+(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op)
+
+;;; Unsigned
+
+(defun below (x max)
+  "Is x between 0 and max?"
+  (compiler-macro-call below x max))
+
+
+;;; Equality
+
+(define-compiler-macro =%2op (n1 n2 &environment env)
+  (cond
+   ((movitz:movitz-constantp n1 env)
+    (let ((n1 (movitz:movitz-eval n1 env)))
+      (etypecase n1
+	((eql 0)
+	 `(do-result-mode-case ()
+	    (:booleans
+	     (with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
+	       (:compile-form (:result-mode :eax) ,n2)
+	       (:testl :eax :eax)))
+	    (t (with-inline-assembly (:returns :boolean-cf=1 :side-effects nil)
+		 (:compile-form (:result-mode :eax) ,n2)
+		 (:cmpl 1 :eax)))))
+	((signed-byte 30)
+	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
+	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+	    (:call-global-pf fast-compare-fixnum-real)))
+	(integer
+	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
+	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+	    (:call-global-pf fast-compare-two-reals))))))
+   ((movitz:movitz-constantp n2 env)
+    `(=%2op ,n2 ,n1))
+   (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
+	 (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+	 (:call-global-pf fast-compare-two-reals)))))
+
+(define-number-relational = =%2op nil :defun-p nil)
+
+(defun = (first-number &rest numbers)
+  (declare (dynamic-extent numbers))
+  (dolist (n numbers t)
+    (unless (= first-number n)
+      (return nil))))
+
+(define-number-relational /= /=%2op :boolean-zf=0 :defun-p nil)
+
+(defun /= (&rest numbers)
+  (declare (dynamic-extent numbers))
+  (do ((p (cdr numbers) (cdr p)))
+      ((null p) t)
+    (do ((v numbers (cdr v)))
+	((eq p v))
+      (when (= (car p) (car v))
+	(return-from /= nil)))))
+
+
+;;;;
+
+(deftype positive-fixnum ()
+  `(integer 0 ,movitz:+movitz-most-positive-fixnum+))
+
+(deftype positive-bignum ()
+  `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *))
+
+(deftype negative-fixnum ()
+  `(integer ,movitz:+movitz-most-negative-fixnum+ -1))
+
+(defun fixnump (x)
+  (typep x 'fixnum))
+
+(defun evenp (x)
+  (compiler-macro-call evenp x))
+
+(defun oddp (x)
+  (compiler-macro-call oddp x))
+
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype signed-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    'integer)
+   ((typep size '(integer 1 *))
+    (list 'integer
+	  (- (ash 1 (1- size)))
+	  (1- (ash 1 (1- size)))))
+   (t (error "Illegal size for signed-byte."))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    (list 'integer 0 (1- (ash 1 size))))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
+;;; 
+
+(defun %negatef (x p0 p1)
+  "Negate x. If x is not eq to p0 or p1, negate x destructively."
+  (etypecase x
+    (fixnum (- x))
+    (bignum
+     (if (or (eq x p0) (eq x p1))
+	 (- x)
+       (with-inline-assembly (:returns :eax)
+	 (:compile-form (:result-mode :eax) x)
+	 (:xorl #xff00 (:eax #.movitz:+other-type-offset+)))))))
+
+;;; Addition
+
+(defun + (&rest terms)
+  (declare (without-check-stack-limit))
+  (numargs-case
+   (1 (x) x)
+   (2 (x y)
+      (macrolet
+	  ((do-it ()
 	     `(number-double-dispatch (x y)
 		((fixnum fixnum)
 		 (with-inline-assembly (:returns :eax)
@@ -315,677 +607,214 @@
 		    retry-not-size1
 		     (:compile-form (:result-mode :eax) y)
 		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		    not-size1
-		     (:declare-label-set retry-jumper (retry-not-size1))
-		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
-		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
-					'retry-jumper)
-				      (:edi (:edi-offset atomically-status))))
-		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
-			    :eax)	; Number of words
-		     (:call-local-pf get-cons-pointer)
-		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
-		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
-			    :edx)
-		     (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
-		    copy-bignum-loop
-		     (:subl ,movitz:+movitz-fixnum-factor+ :edx)
-		     (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
-		     (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
-		     (:jnz 'copy-bignum-loop)
-
-		     (:load-lexical (:lexical-binding x) :ebx)
-		     (:xorl :edx :edx)	; counter
-		     (:xorl :ecx :ecx)	; Carry
-		    add-bignum-loop
-		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-		     (:jbe '(:sub-program (zero-padding-loop)
-			     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum
-						      'movitz::bigit0)))
-			     (:sbbl :ecx :ecx)
-			     (:negl :ecx) ; ECX = Add's Carry.
-			     (:addl 4 :edx)
-			     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-			     (:jae 'zero-padding-loop)
-			     (:jmp 'add-bignum-done)))
-		     (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
-			    :ecx)
-		     (:jc '(:sub-program (term1-carry)
-			    ;; The digit + carry carried over, ECX = 0
-			    (:addl 1 :ecx)
-			    (:addl 4 :edx)
-			    (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-			    (:jae 'add-bignum-loop)
-			    (:jmp 'add-bignum-done)))
-		     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-		     (:sbbl :ecx :ecx)
-		     (:negl :ecx)	; ECX = Add's Carry.
-		     (:addl 4 :edx)
-		     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-		     (:jae 'add-bignum-loop)
-		    add-bignum-done
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-			      :ecx)
-		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
-			    :ecx)
-		     (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
-		     (:je 'no-expansion)
-		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
-		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
-		    no-expansion
-		     (:call-local-pf cons-commit)
-		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
-				      (:edi (:edi-offset atomically-status))))
-		    pfix-pbig-done)
-		   ))
-		(((integer * -1) (integer 0 *))
-		 (- y (- x)))
-		(((integer 0 *) (integer * -1))
-		 (- x (- y)))
-		(((integer * -1) (integer * -1))
-		 (%negatef (+ (- x) (- y)) x y))
-		)))
-	(do-it)))
-   (t (&rest terms)
-      (declare (dynamic-extent terms))
-      (if (null terms)
-	  0
-	(reduce #'+ terms)))))
-
-(defun 1+ (number)
-  (+ 1 number))
-
-(define-compiler-macro 1+ (number)
-  `(+ 1 ,number))
-
-(defun 1- (number)
-  (+ -1 number))
-
-(define-compiler-macro 1- (number)
-  `(+ -1 ,number))
-
-(define-modify-macro incf (&optional (delta-form 1)) +)
-
-;;; Subtraction
-
-(define-compiler-macro - (&whole form &rest operands &environment env)
-  (case (length operands)
-    (0 0)
-    (1 (let ((x (first operands)))
-	 (if (movitz:movitz-constantp x env)
-	     (- (movitz:movitz-eval x env))
-	   form)))
-    (2 (let ((minuend (first operands))
-	     (subtrahend (second operands)))
-	 (cond
-	  ((movitz:movitz-constantp subtrahend env)
-	   `(+ ,minuend ,(- (movitz:movitz-eval subtrahend env))))
-	  (t form))))
-    (t `(- ,(first operands) (+ ,@(rest operands))))))
-
-(defun - (minuend &rest subtrahends)
-  (declare (dynamic-extent subtrahends))
-  (numargs-case
-   (1 (x)
-      (macrolet
-	  ((do-it ()
-	     `(with-inline-assembly (:returns :eax)
-		(:compile-form (:result-mode :eax) x)
-		(:testb ,movitz:+movitz-fixnum-zmask+ :al)
-		(:jnz '(:sub-program (not-fixnum)
-			(:leal (:eax ,(- (movitz:tag :other))) :ecx)
-			(:testb 7 :cl)
-			(:jnz '(:sub-program (not-a-number)
-				(:compile-form (:result-mode :ignore)
-				 (error 'type-error :expected-type 'number :datum x))))
-			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
-			(:cmpb ,(movitz:tag :bignum) :cl)
-			(:jne 'not-a-number)
-			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
-			(:jne 'not-most-negative-fixnum)
-			(:cmpl ,(- most-negative-fixnum)
-			 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:jne 'not-most-negative-fixnum)
-			(:movl ,(ldb (byte 32 0)
-				 (* most-negative-fixnum movitz::+movitz-fixnum-factor+))
-			 :eax)
-			(:jmp 'fix-ok)
-			not-most-negative-fixnum
-			(:compile-form (:result-mode :eax)
-			 (copy-bignum x))
-			(:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)))
-			(:jmp 'fix-ok)))
-		(:negl :eax)
-		(:jo '(:sub-program (fix-overflow)
-		       (:compile-form (:result-mode :eax)
-			,(1+ movitz:+movitz-most-positive-fixnum+))
-		       (:jmp 'fix-ok)))
-	       fix-ok
-		)))
-	(do-it)))
-   (2 (minuend subtrahend)
-      (macrolet
-	  ((do-it ()
-	     `(number-double-dispatch (minuend subtrahend)
-		((t (eql 0))
-		 minuend)
-		(((eql 0) t)
-		 (- subtrahend))
-		((fixnum fixnum)
-		 (with-inline-assembly (:returns :eax :side-effects nil)
-		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
-		   (:subl :ebx :eax)
-		   (:into)))
-		((positive-bignum fixnum)
-		 (+ (- subtrahend) minuend))
-		((fixnum positive-bignum)
-		 (- (+ (- minuend) subtrahend)))
-		((positive-bignum positive-bignum)
-		 (cond
-		  ((= minuend subtrahend)
-		   0)
-		  ((< minuend subtrahend)
-		   (let ((x (- subtrahend minuend)))
-		     (%negatef x subtrahend minuend)))
-		  (t (%bignum-canonicalize
-		      (with-inline-assembly (:returns :eax)
-			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
-			(:xorl :edx :edx) ; counter
-			(:xorl :ecx :ecx) ; carry
-		       sub-loop
-			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
-			       :ecx)
-			(:jc '(:sub-program (carry-overflow)
-			       ;; Just propagate carry
-			       (:addl 1 :ecx)
-			       (:addl 4 :edx)
-			       (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-			       (:jne 'sub-loop)
-			       (:jmp 'bignum-sub-done)))
-			(:subl :ecx
-			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:sbbl :ecx :ecx)
-			(:negl :ecx)
-			(:addl 4 :edx)
-			(:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
-			(:jne 'sub-loop)
-			(:subl :ecx
-			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:jnc 'bignum-sub-done)
-		       propagate-carry
-			(:addl 4 :edx)
-			(:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:jc 'propagate-carry)
-		       bignum-sub-done
-			)))))
-		(((integer 0 *) (integer * -1))
-		 (+ minuend (- subtrahend)))
-		(((integer * -1) (integer 0 *))
-		 (%negatef (+ (- minuend) subtrahend) minuend subtrahend))
-		(((integer * -1) (integer * -1))
-		 (+ minuend (- subtrahend)))
-		)))
-	(do-it)))
-   (t (minuend &rest subtrahends)
-      (declare (dynamic-extent subtrahends))
-      (if subtrahends
-	  (reduce #'- subtrahends :initial-value minuend)
-	(- minuend)))))
-    
-(define-modify-macro decf (&optional (delta-form 1)) -)
-
-;;; Comparison
-
-(define-primitive-function fast-compare-two-reals (n1 n2)
-  "Compare two numbers (i.e. set EFLAGS accordingly)."
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :nothing) ; unspecified
-	    (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-	    (:jnz 'n1-not-fixnum)
-	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-	    (:jnz 'n2-not-fixnum-but-n1-is)
-	    (:cmpl :ebx :eax)		; both were fixnum
-	    (:ret)
-	   n1-not-fixnum		; but we don't know about n2
-	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-	    (:jnz 'neither-is-fixnum)
-	    ;; n2 is fixnum
-	    (:locally (:jmp (:edi (:edi-offset fast-compare-real-fixnum))))
-	   n2-not-fixnum-but-n1-is
-	    (:locally (:jmp (:edi (:edi-offset fast-compare-fixnum-real))))
-	   neither-is-fixnum
-	    ;; Check that both numbers are bignums, and compare them.
-	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (n1-not-bignum)
-		    (:int 107)))
-	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-	    (:cmpb ,(movitz:tag :bignum) :cl)
-	    (:jne 'n1-not-bignum)
-
-	    (:cmpl :eax :ebx)		; If they are EQ, they are certainly =
-	    (:je '(:sub-program (n1-and-n2-are-eq)
-		   (:ret)))
-
-	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
-	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (n2-not-bignum)
-		    (:int 107)))
-	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
-	    (:cmpb ,(movitz:tag :bignum) :cl)
-	    (:jne 'n2-not-bignum)
-
-	    (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign)))
-	    (:jne '(:sub-program (different-signs)
-		    ;; Comparing the sign-bytes sets up EFLAGS correctly!
-		    (:ret)))
-	    (:testl #xff00 :ecx)
-	    (:jnz 'compare-negatives)
-	    ;; Both n1 and n2 are positive bignums.
-
-	    (:shrl 16 :ecx)
-	    (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
-	    (:jne '(:sub-program (positive-different-sizes)
-		    (:ret)))
-
-	    ;; Both n1 and n2 are positive bignums of the same size, namely ECX.
-	    (:movl :ecx :edx)		; counter
-	   positive-compare-loop
-	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
-	    (:jz 'positive-compare-lsb)
-	    (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-	    (:je 'positive-compare-loop)
-	   positive-compare-lsb
-	    ;; Now we have to make the compare act as unsigned, which is why
-	    ;; we compare zero-extended 16-bit quantities.
-	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)		; First compare upper 16 bits.
-	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)
-	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
-	    (:jne 'upper-16-decisive)
-	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		     :ecx)		; Then compare lower 16 bits.
-	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		     :ecx)		; Then compare lower 16 bits.
-	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
-	   upper-16-decisive
-	    (:ret)
-	    
-	   compare-negatives
-	    ;; Moth n1 and n2 are negative bignums.
-
-	    (:shrl 16 :ecx)
-	    (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx)
-	    (:jne '(:sub-program (negative-different-sizes)
-		    (:ret)))
-
-	    ;; Both n1 and n2 are negative bignums of the same size, namely ECX.
-	    (:movl :ecx :edx)		; counter
-	   negative-compare-loop
-	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
-	    (:jz 'negative-compare-lsb)
-	    (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-	    (:je 'negative-compare-loop)
-	    (:ret)
-	   negative-compare-lsb		; it's down to the LSB bigits.
-	    ;; Now we have to make the compare act as unsigned, which is why
-	    ;; we compare zero-extended 16-bit quantities.
-	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)		; First compare upper 16 bits.
-	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)
-	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
-	    (:jne 'negative-upper-16-decisive)
-	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		     :ecx)		; Then compare lower 16 bits.
-	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		     :ecx)		; Then compare lower 16 bits.
-	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
-	   negative-upper-16-decisive
-	    (:ret))))
-    (do-it)))
-
-(define-primitive-function fast-eql (x y)
-  "Compare EAX and EBX under EQL, result in ZF.
-Preserve EAX and EBX."
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :nothing) ; unspecified
-	    (:cmpl :eax :ebx)		; EQ?
-	    (:je 'done)
-	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-	    (:testb 7 :cl)
-	    (:jne 'done)
-	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
-	    (:testb 7 :cl)
-	    (:jne 'done)
-	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-	    (:cmpb ,(movitz:tag :bignum) :cl)
-	    (:jne 'done)
-	    (:cmpl :ecx (:ebx ,movitz:+other-type-offset+))
-	    (:jne 'done)
-	    ;; Ok.. we have two bignums of identical sign and size.
-	    (:shrl 16 :ecx)
-	    (:movl :ecx :edx)		; counter
-	   compare-loop
-	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
-	    (:jz 'done)
-	    (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
-	    (:je 'compare-loop)
-	   done
-	    (:ret))))
-    (do-it)))
-
-(define-primitive-function fast-compare-fixnum-real (n1 n2)
-  "Compare (known) fixnum <n1> with real <n2>."
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :nothing) ; unspecified
-	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-	    (:jnz 'n2-not-fixnum)
-	    (:cmpl :ebx :eax)
-	    (:ret)
-	   n2-not-fixnum
-	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
-	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (not-integer)
-		    (:int 107)
-		    (:jmp 'not-integer)))
-	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
-	    (:cmpw ,(movitz:tag :bignum 0) :cx)
-	    (:jne 'not-plusbignum)
-	    ;; compare eax with something bigger
-	    (:cmpl #x10000000 :edi)
-	    (:ret)
-	   not-plusbignum
-	    (:cmpw ,(movitz:tag :bignum #xff) :cx)
-	    (:jne 'not-integer)
-	    ;; compare ebx with something bigger
-	    (:cmpl #x-10000000 :edi)
-	    (:ret))))
-    (do-it)))
-
-(define-primitive-function fast-compare-real-fixnum (n1 n2)
-  "Compare real <n1> with fixnum <n2>."
-  (with-inline-assembly (:returns :nothing) ; unspecified
-    (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-    (:jnz 'not-fixnum)
-    (:cmpl :ebx :eax)
-    (:ret)
-   not-fixnum
-    (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
-    (:testb 7 :cl)
-    (:jnz '(:sub-program (not-integer)
-	    (:int 107)
-	    (:jmp 'not-integer)))
-    (:movl (:eax #.movitz:+other-type-offset+) :ecx)
-    (:cmpw #.(movitz:tag :bignum 0) :cx)
-    (:jne 'not-plusbignum)
-    ;; compare ebx with something bigger
-    (:cmpl #x-10000000 :edi)
-    (:ret)
-   not-plusbignum
-    (:cmpw #.(movitz:tag :bignum #xff) :cx)
-    (:jne 'not-integer)
-    ;; compare ebx with something bigger
-    (:cmpl #x10000000 :edi)
-    (:ret)))
-
-;;;
-
-(define-compiler-macro <=%3op (min x max &environment env)
-  (cond
-   ((and (movitz:movitz-constantp min env)
-	 (movitz:movitz-constantp max env))
-    (let ((min (movitz:movitz-eval min env))
-	  (max (movitz:movitz-eval max env)))
-      (check-type min fixnum)
-      (check-type max fixnum)
-      ;; (warn "~D -- ~D" min max)
-      (cond
-       ((movitz:movitz-constantp x env)
-	(<= min (movitz:movitz-eval x env) max))
-       ((< max min)
-	nil)
-       ((= max min)
-	`(= ,x ,min))
-       ((minusp min)
-	`(let ((x ,x))
-	   (and (<= ,min x) (<= x ,max))))
-       ((= 0 min)
-	`(with-inline-assembly (:returns :boolean-cf=1)
-	   (:compile-form (:result-mode :eax) ,x)
-	   (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-	   (:jnz '(:sub-program () (:int 107)))
-	   (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)))
-       (t `(do-result-mode-case ()
-	     (:booleans
-	      (with-inline-assembly (:returns :boolean-zf=0)
-		(:compile-form (:result-mode :eax) ,x)
-		(:testb ,movitz::+movitz-fixnum-zmask+ :al)
-		(:jnz '(:sub-program () (:int 107)))
-		(:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax)
-		(:sbbl :ecx :ecx)
-		(:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)
-		(:adcl 0 :ecx)))
-	     (t (with-inline-assembly (:returns (:boolean-ecx 1 0))
-		  (:compile-form (:result-mode :eax) ,x)
-		  (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-		  (:jnz '(:sub-program () (:int 107)))
-		  (:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax)
-		  (:sbbl :ecx :ecx)
-		  (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)
-		  (:adcl 0 :ecx))))))))
-   #+ignore				; this is buggy.
-   ((movitz:movitz-constantp min env)
-    (let ((min (movitz:movitz-eval min env)))
-      (check-type min fixnum)
-      (cond
-       ((minusp min)
-	`(let ((x ,x))
-	   (and (<= ,min x) (<= x ,max))))
-       (t `(do-result-mode-case ()
-	     (:booleans
-	      (with-inline-assembly (:returns :boolean-zf=1)
-		(:compile-two-forms (:eax :ebx) ,x ,max)
-		(:movl :eax :ecx)
-		(:orl :ebx :ecx)
-		(:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-		(:jne '(:sub-program () (:int 107)))
-		(:cmpl :eax :ebx)
-		(:sbbl :ecx :ecx)
-		,@(unless (= 0 min)
-		    `((:subl ,(* min movitz::+movitz-fixnum-factor+) :ebx)))
-		(:addl :ebx :ebx)
-		(:adcl 0 :ecx)))
-	     (t (with-inline-assembly (:returns (:boolean-ecx 0 1))
-		  (:compile-two-forms (:eax :ebx) ,x ,max)
-		  (:movl :eax :ecx)
-		  (:orl :ebx :ecx)
-		  (:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-		  (:jne '(:sub-program () (:int 107)))
-		  (:cmpl :eax :ebx)	; if x>max, CF=1
-		  (:sbbl :ecx :ecx)	; ecx = x>max ? -1 : 0
-		  ,@(unless (= 0 min)
-		      `((:subl ,(* min movitz::+movitz-fixnum-factor+) :ebx)))
-		  (:addl :ebx :ebx)	; if x<min, CF=1
-		  (:adcl 0 :ecx)	; 
-		  (:andl 1 :ecx))))))))
-   (t `(let ((x ,x))
-	 (and (<= ,min x) (<= x ,max))))))
-       
-
-(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
-  `(progn
-     ,(when condition
-	`(define-compiler-macro ,2op-name (n1 n2)
-	   (cond
-	    ((movitz:movitz-constantp n1)
-	     (let ((n1 (movitz::movitz-eval n1)))
-	       (check-type n1 (signed-byte 30))
-	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-fixnum-real))))
-	    ((movitz:movitz-constantp n2)
-	     (let ((n2 (movitz::movitz-eval n2)))
-	       (check-type n2 (signed-byte 30))
-	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-real-fixnum))))
-	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-two-reals))))))
-
-     (defun ,2op-name (n1 n2)
-       (,2op-name n1 n2))
-
-     (define-compiler-macro ,name (&whole form number &rest more-numbers)
-       (case (length more-numbers)
-	 (0 `(progn ,number t))
-	 (1 `(,',2op-name ,number ,(first more-numbers)))
-	 ,@(when 3op-name
-	     `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers)))))
-	 (t #+ignore (when (= 2 (length more-numbers))
-		       (warn "3op: ~S" form))
-	  `(and (,',2op-name ,number ,(first more-numbers))
-		  (,',name , at more-numbers)))))
-
-     ,(when defun-p
-	`(defun ,name (number &rest more-numbers)
-	   (declare (dynamic-extent more-numbers))
-	   (cond
-	    ((null more-numbers)
-	     (check-type number fixnum)
-	     t)
-	    ((not (cdr more-numbers))
-	     (,2op-name number (first more-numbers)))
-	    (t (and (,2op-name number (first more-numbers))
-		    (do ((p more-numbers (cdr p)))
-			((not (cdr p)) t)
-		      (unless (,2op-name (car p) (cadr p))
-			(return nil))))))))))
-
-(define-number-relational >= >=%2op :boolean-greater-equal)
-(define-number-relational > >%2op :boolean-greater)
-(define-number-relational < <%2op :boolean-less)
-(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op)
-
-;;; Unsigned
-
-(define-compiler-macro below (&whole form x max &environment env)
-  (let ((below-not-integer (gensym "below-not-integer-")))
-    (if (movitz:movitz-constantp max env)
-	`(with-inline-assembly (:returns :boolean-cf=1)
-	   (:compile-form (:result-mode :eax) ,x)
-	   (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-	   (:jnz '(:sub-program (,below-not-integer) (:int 107)))
-	   (:cmpl ,(* (movitz:movitz-eval max env)
-		      movitz::+movitz-fixnum-factor+)
-		  :eax))
-      `(with-inline-assembly (:returns :boolean-cf=1)
-	 (:compile-two-forms (:eax :ebx) ,x ,max)
-	 (:movl :eax :ecx)
-	 (:orl :ebx :ecx)
-	 (:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-	 (:jnz '(:sub-program (,below-not-integer) (:int 107)))
-	 (:cmpl :ebx :eax)))))
-
-(defun below (x max)
-  "Is x between 0 and max?"
-  (below x max))
-
-
-;;; Equality
+		    not-size1
+		     (:declare-label-set retry-jumper (retry-not-size1))
+		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
+		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
+					'retry-jumper)
+				      (:edi (:edi-offset atomically-status))))
+		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
+			    :eax)	; Number of words
+		     (:call-local-pf get-cons-pointer)
+		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
+		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
+			    :edx)
+		     (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
+		    copy-bignum-loop
+		     (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+		     (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
+		     (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
+		     (:jnz 'copy-bignum-loop)
 
-(define-compiler-macro =%2op (n1 n2 &environment env)
-  (cond
-   ((movitz:movitz-constantp n1 env)
-    (let ((n1 (movitz:movitz-eval n1 env)))
-      (etypecase n1
-	((eql 0)
-	 `(do-result-mode-case ()
-	    (:booleans
-	     (with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
-	       (:compile-form (:result-mode :eax) ,n2)
-	       (:testl :eax :eax)))
-	    (t (with-inline-assembly (:returns :boolean-cf=1 :side-effects nil)
-		 (:compile-form (:result-mode :eax) ,n2)
-		 (:cmpl 1 :eax)))))
-	((signed-byte 30)
-	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
-	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	    (:call-global-pf fast-compare-fixnum-real)))
-	(integer
-	 `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
-	    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	    (:call-global-pf fast-compare-two-reals))))))
-   ((movitz:movitz-constantp n2 env)
-    `(=%2op ,n2 ,n1))
-   (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil)
-	 (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-	 (:call-global-pf fast-compare-two-reals)))))
+		     (:load-lexical (:lexical-binding x) :ebx)
+		     (:xorl :edx :edx)	; counter
+		     (:xorl :ecx :ecx)	; Carry
+		    add-bignum-loop
+		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:jbe '(:sub-program (zero-padding-loop)
+			     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum
+						      'movitz::bigit0)))
+			     (:sbbl :ecx :ecx)
+			     (:negl :ecx) ; ECX = Add's Carry.
+			     (:addl 4 :edx)
+			     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			     (:jae 'zero-padding-loop)
+			     (:jmp 'add-bignum-done)))
+		     (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			    :ecx)
+		     (:jc '(:sub-program (term1-carry)
+			    ;; The digit + carry carried over, ECX = 0
+			    (:addl 1 :ecx)
+			    (:addl 4 :edx)
+			    (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			    (:jae 'add-bignum-loop)
+			    (:jmp 'add-bignum-done)))
+		     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:sbbl :ecx :ecx)
+		     (:negl :ecx)	; ECX = Add's Carry.
+		     (:addl 4 :edx)
+		     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:jae 'add-bignum-loop)
+		    add-bignum-done
+		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			      :ecx)
+		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
+			    :ecx)
+		     (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:je 'no-expansion)
+		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
+		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+		    no-expansion
+		     (:call-local-pf cons-commit)
+		     (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+				      (:edi (:edi-offset atomically-status))))
+		    pfix-pbig-done)
+		   ))
+		(((integer * -1) (integer 0 *))
+		 (- y (- x)))
+		(((integer 0 *) (integer * -1))
+		 (- x (- y)))
+		(((integer * -1) (integer * -1))
+		 (%negatef (+ (- x) (- y)) x y))
+		)))
+	(do-it)))
+   (t (&rest terms)
+      (declare (dynamic-extent terms))
+      (if (null terms)
+	  0
+	(reduce #'+ terms)))))
 
-(define-number-relational = =%2op nil :defun-p nil)
+(defun 1+ (number)
+  (+ 1 number))
 
-(defun = (first-number &rest numbers)
-  (declare (dynamic-extent numbers))
-  (dolist (n numbers t)
-    (unless (= first-number n)
-      (return nil))))
+(defun 1- (number)
+  (+ -1 number))
 
-(define-number-relational /= /=%2op :boolean-zf=0 :defun-p nil)
+;;; Subtraction
 
-(defun /= (&rest numbers)
-  (declare (dynamic-extent numbers))
-  (do ((p (cdr numbers) (cdr p)))
-      ((null p) t)
-    (do ((v numbers (cdr v)))
-	((eq p v))
-      (when (= (car p) (car v))
-	(return-from /= nil)))))
+(defun - (minuend &rest subtrahends)
+  (declare (dynamic-extent subtrahends))
+  (numargs-case
+   (1 (x)
+      (macrolet
+	  ((do-it ()
+	     `(with-inline-assembly (:returns :eax)
+		(:compile-form (:result-mode :eax) x)
+		(:testb ,movitz:+movitz-fixnum-zmask+ :al)
+		(:jnz '(:sub-program (not-fixnum)
+			(:leal (:eax ,(- (movitz:tag :other))) :ecx)
+			(:testb 7 :cl)
+			(:jnz '(:sub-program (not-a-number)
+				(:compile-form (:result-mode :ignore)
+				 (error 'type-error :expected-type 'number :datum x))))
+			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
+			(:cmpb ,(movitz:tag :bignum) :cl)
+			(:jne 'not-a-number)
+			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
+			(:jne 'not-most-negative-fixnum)
+			(:cmpl ,(- most-negative-fixnum)
+			 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jne 'not-most-negative-fixnum)
+			(:movl ,(ldb (byte 32 0)
+				 (* most-negative-fixnum movitz::+movitz-fixnum-factor+))
+			 :eax)
+			(:jmp 'fix-ok)
+			not-most-negative-fixnum
+			(:compile-form (:result-mode :eax)
+			 (copy-bignum x))
+			(:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)))
+			(:jmp 'fix-ok)))
+		(:negl :eax)
+		(:jo '(:sub-program (fix-overflow)
+		       (:compile-form (:result-mode :eax)
+			,(1+ movitz:+movitz-most-positive-fixnum+))
+		       (:jmp 'fix-ok)))
+	       fix-ok
+		)))
+	(do-it)))
+   (2 (minuend subtrahend)
+      (macrolet
+	  ((do-it ()
+	     `(number-double-dispatch (minuend subtrahend)
+		((t (eql 0))
+		 minuend)
+		(((eql 0) t)
+		 (- subtrahend))
+		((fixnum fixnum)
+		 (with-inline-assembly (:returns :eax :side-effects nil)
+		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
+		   (:subl :ebx :eax)
+		   (:into)))
+		((positive-bignum fixnum)
+		 (+ (- subtrahend) minuend))
+		((fixnum positive-bignum)
+		 (- (+ (- minuend) subtrahend)))
+		((positive-bignum positive-bignum)
+		 (cond
+		  ((= minuend subtrahend)
+		   0)
+		  ((< minuend subtrahend)
+		   (let ((x (- subtrahend minuend)))
+		     (%negatef x subtrahend minuend)))
+		  (t (%bignum-canonicalize
+		      (with-inline-assembly (:returns :eax)
+			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
+			(:xorl :edx :edx) ; counter
+			(:xorl :ecx :ecx) ; carry
+		       sub-loop
+			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			       :ecx)
+			(:jc '(:sub-program (carry-overflow)
+			       ;; Just propagate carry
+			       (:addl 1 :ecx)
+			       (:addl 4 :edx)
+			       (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			       (:jne 'sub-loop)
+			       (:jmp 'bignum-sub-done)))
+			(:subl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:sbbl :ecx :ecx)
+			(:negl :ecx)
+			(:addl 4 :edx)
+			(:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			(:jne 'sub-loop)
+			(:subl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jnc 'bignum-sub-done)
+		       propagate-carry
+			(:addl 4 :edx)
+			(:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jc 'propagate-carry)
+		       bignum-sub-done
+			)))))
+		(((integer 0 *) (integer * -1))
+		 (+ minuend (- subtrahend)))
+		(((integer * -1) (integer 0 *))
+		 (%negatef (+ (- minuend) subtrahend) minuend subtrahend))
+		(((integer * -1) (integer * -1))
+		 (+ minuend (- subtrahend)))
+		)))
+	(do-it)))
+   (t (minuend &rest subtrahends)
+      (declare (dynamic-extent subtrahends))
+      (if subtrahends
+	  (reduce #'- subtrahends :initial-value minuend)
+	(- minuend)))))
 
 ;;;
 
 (defun zerop (number)
   (= 0 number))
 
-(define-compiler-macro zerop (number)
-  `(= 0 ,number))
-
 (defun plusp (number)
   (> number 0))
 
-(define-compiler-macro plusp (number)
-  `(> ,number 0))
-
 (defun minusp (number)
   (< number 0))
 
-(define-compiler-macro minusp (number)
-  `(< ,number 0))
-
-(define-compiler-macro abs (x)
-  `(let ((x ,x))
-     (if (>= x 0) x (- x))))
-
 (defun abs (x)
-  (abs x))
+  (compiler-macro-call abs x))
 
 (defun signum (x)
   (cond
@@ -995,19 +824,10 @@
 
 ;;;
 
-(define-compiler-macro max (&whole form first-number &rest more-numbers)
-  (case (length more-numbers)
-    (0 first-number)
-    (1 `(let ((x ,first-number)
-	      (y ,(car more-numbers)))
-	  (if (>= x y) x y)))
-    ((2 3 4)
-     `(max ,first-number (max , at more-numbers)))
-    (t form)))
-
 (defun max (number1 &rest numbers)
   (numargs-case
-   (2 (x y) (max x y))
+   (2 (x y)
+      (compiler-macro-call max x y))
    (t (number1 &rest numbers)
       (declare (dynamic-extent numbers))
       (let ((max number1))
@@ -1015,19 +835,10 @@
 	  (when (> x max)
 	    (setq max x)))))))
 
-(define-compiler-macro min (&whole form first-number &rest more-numbers)
-  (case (length more-numbers)
-    (0 first-number)
-    (1 `(let ((x ,first-number)
-	      (y ,(car more-numbers)))
-	  (if (<= x y) x y)))
-    ((2 3 4)
-     `(min ,first-number (min , at more-numbers)))
-    (t form)))
-
 (defun min (number1 &rest numbers)
   (numargs-case
-   (2 (x y) (min x y))
+   (2 (x y)
+      (compiler-macro-call min x y))
    (t (number1 &rest numbers)
       (declare (dynamic-extent numbers))
       (let ((min number1))
@@ -1037,54 +848,6 @@
 
 ;; shift 
 
-(define-compiler-macro ash (&whole form integer count &environment env)
-  (if (not (movitz:movitz-constantp count env))
-      form
-    (let ((count (movitz:movitz-eval count env)))
-      (cond
-       ((movitz:movitz-constantp integer env)
-	(ash (movitz::movitz-eval integer env) count))
-       ((= 0 count)
-	integer)
-       (t form
-	  #+igore
-	  (let ((load-integer `((:compile-form (:result-mode :register) ,integer)
-				(:testb ,movitz::+movitz-fixnum-zmask+ (:result-register-low8))
-				(:jnz '(:sub-program () (:int 107) (:jmp (:pc+ -4)))))))
-	    (cond
-	     ((<= 1 count 4)
-	      `(with-inline-assembly (:returns :register :side-effects nil)
-		 , at load-integer
-		 ,@(loop repeat count
-		       append `((:addl (:result-register) (:result-register))
-				(:into)))))
-	     ((< 0 count #.(cl:1- movitz::+movitz-fixnum-bits+))
-	      `(with-inline-assembly (:returns :register :side-effects nil :type integer)
-		 , at load-integer
-		 (:cmpl ,(ash 1 (- (- 31 0) count))
-			(:result-register))
-		 (:jge '(:sub-program () (:int 4)))
-		 (:cmpl ,(- (ash 1 (- (- 31 0) count)))
-			(:result-register))
-		 (:jl '(:sub-program () (:int 4)))
-		 (:shll ,count (:result-register))))
-	     ((= -1 count)
-	      `(with-inline-assembly (:returns :register :side-effects nil :type integer)
-		 , at load-integer
-		 (:andb #.(cl:logxor #xfe (cl:* 2 movitz::+movitz-fixnum-zmask+)) (:result-register-low8))
-		 (:sarl 1 (:result-register))))
-	     ((> 0 count #.(cl:- (cl:1- movitz::+movitz-fixnum-bits+)))
-	      `(with-inline-assembly (:returns :register :side-effects nil :type integer)
-		 , at load-integer
-		 (:andl ,(ldb (byte 32 0)
-			      (ash movitz:+movitz-most-positive-fixnum+
-				   (- movitz:+movitz-fixnum-shift+ count)))
-			(:result-register))
-		 (:sarl ,(- count) (:result-register))))
-	     ((minusp count)
-	      `(if (minusp ,integer) -1 0))
-	     (t `(if (= 0 ,integer) 0 (with-inline-assembly (:returns :non-local-exit) (:int 4)))))))))))
-  
 (defun ash (integer count)
   (cond
    ((= 0 count)
@@ -1202,30 +965,6 @@
 
 ;;; Multiplication
 
-(define-compiler-macro * (&whole form &rest operands &environment env)
-  (case (length operands)
-    (0 0)
-    (1 (first operands))
-    (2 (let ((factor1 (first operands))
-	     (factor2 (second operands)))
-	 (cond
-	  ((and (movitz:movitz-constantp factor1 env)
-		(movitz:movitz-constantp factor2 env))
-	   (* (movitz:movitz-eval factor1 env)
-	      (movitz:movitz-eval factor2 env)))
-	  ((movitz:movitz-constantp factor2 env)
-	   `(* ,(movitz:movitz-eval factor2 env) ,factor1))
-	  ((movitz:movitz-constantp factor1 env)
-	   (let ((f1 (movitz:movitz-eval factor1 env)))
-	     (check-type f1 integer)
-	     (case f1
-	       (0 `(progn ,factor2 0))
-	       (1 factor2)
-	       (2 `(let ((x ,factor2)) (+ x x)))
-	       (t `(no-macro-call * ,factor1 ,factor2)))))
-	  (t `(no-macro-call * ,factor1 ,factor2)))))
-    (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))
-
 (defun * (&rest factors)
   (numargs-case
    (1 (x) x)
@@ -1637,16 +1376,6 @@
 (defun byte (size position)
   (+ (* size #x400) position))
 
-(define-compiler-macro byte (&whole form size position)
-  (cond
-   ((and (integerp size)
-	 (integerp position))
-    (+ (* size #x400) position))
-   #+ignore
-   ((integerp size)
-    `(+ ,position ,(* size #x400)))
-   (t form)))
-
 (defun byte-size (bytespec)
   (truncate bytespec #x400))
 
@@ -1671,24 +1400,6 @@
 	       (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))))
     (do-it)))
 
-(define-compiler-macro logand (&whole form &rest integers &environment env)
-  (let ((constant-folded-integers (loop for x in integers
-				      with folded-constant = -1
-				      if (and (movitz:movitz-constantp x env)
-					      (not (= -1 (movitz:movitz-eval x env))))
-				      do (setf folded-constant
-					   (logand folded-constant (movitz:movitz-eval x env)))
-				      else collect x into non-constants
-				      finally (return (if (= -1 folded-constant)
-							  non-constants
-							(cons folded-constant non-constants))))))
-    (case (length constant-folded-integers)
-      (0 0)
-      (1 (first constant-folded-integers))
-      (2 `(no-macro-call logand ,(first constant-folded-integers) ,(second constant-folded-integers)))
-      (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers))
-		  ,@(cddr constant-folded-integers))))))
-
 (defun logand (&rest integers)
   (numargs-case
    (1 (x) x)
@@ -1834,24 +1545,6 @@
 	  0
 	(reduce #'logior integers)))))
 
-(define-compiler-macro logior (&whole form &rest integers &environment env)
-  (let ((constant-folded-integers (loop for x in integers
-				      with folded-constant = 0
-				      if (and (movitz:movitz-constantp x env)
-					      (not (zerop (movitz:movitz-eval x env))))
-				      do (setf folded-constant
-					   (logior folded-constant (movitz:movitz-eval x env)))
-				      else collect x into non-constants
-				      finally (return (if (= 0 folded-constant)
-							  non-constants
-							(cons folded-constant non-constants))))))
-    (case (length constant-folded-integers)
-      (0 0)
-      (1 (first constant-folded-integers))
-      (2 `(no-macro-call logior ,(first constant-folded-integers) ,(second constant-folded-integers)))
-      (t `(logior (logior ,(first constant-folded-integers) ,(second constant-folded-integers))
-		  ,@(cddr constant-folded-integers))))))
-
 (defun logxor (&rest integers)
   (numargs-case
    (1 (x) x)
@@ -2271,104 +1964,10 @@
 				      (:edi (:edi-offset atomically-status))))
 		    ldb-done))))
 	   (do-it)))))))
-    
-
-(define-compiler-macro ldb%byte (&whole form &environment env size position integer)
-  "This is LDB with explicit byte-size and position parameters."
-  (cond
-   ((and (movitz:movitz-constantp size env)
-	 (movitz:movitz-constantp position env)
-	 (movitz:movitz-constantp integer env))
-    (ldb (byte (movitz:movitz-eval size env)
-	       (movitz:movitz-eval position env))
-	 (movitz:movitz-eval integer env))) ; constant folding
-   ((and (movitz:movitz-constantp size env)
-	 (movitz:movitz-constantp position env))
-    (let* ((size (movitz:movitz-eval size env))
-	   (position (movitz:movitz-eval position env))
-	   (result-type `(unsigned-byte ,size)))
-      (cond
-       ((or (minusp size) (minusp position))
-	(error "Negative byte-spec for ldb."))
-       ((= 0 size)
-	`(progn ,integer 0))
-       ((<= (+ size position) (- 31 movitz:+movitz-fixnum-shift+))
-	`(with-inline-assembly (:returns :register
-					 :type ,result-type)
-	   (:compile-form (:result-mode :eax) ,integer)
-	   (:call-global-pf unbox-u32)
-	   (:andl ,(mask-field (byte size position) -1) :ecx)
-	   ,@(unless (zerop position)
-	       `((:shrl ,position :ecx)))
-	   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) (:result-register))))
-       ((<= (+ size position) 32)
-	`(with-inline-assembly-case (:type ,result-type)
-	   (do-case (t :eax :labels (nix done))
-	     (:compile-form (:result-mode :eax) ,integer)
-	     ,@(cond
-		((and (= 0 position) (= 32 size))
-		 ;; If integer is a positive bignum with one bigit, return it.
-		 `((:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		   (:testb 7 :cl)
-		   (:jnz 'nix)
-		   (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0))
-			  (:eax ,movitz:+other-type-offset+))
-		   (:je 'done)))
-		((and (= 0 position) (<= (- 32 movitz:+movitz-fixnum-shift+) size ))
-		 `((:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		   (:testb 7 :cl)
-		   (:jnz 'nix)
-		   (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0))
-			  (:eax ,movitz:+other-type-offset+))
-		   (:jne 'nix)
-		   (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
-			  :ecx)
-		   (:testl ,(logxor #xffffffff (mask-field (byte size 0) -1))
-			   :ecx)
-		   (:jz 'done)
-		   (:andl ,(mask-field (byte size 0) -1)
-			  :ecx)
-		   (:call-local-pf box-u32-ecx)
-		   (:jmp 'done))))
-	    nix
-	     (:call-global-pf unbox-u32)
-	     ,@(unless (= 32 (- size position))
-		 `((:andl ,(mask-field (byte size position) -1) :ecx)))
-	     ,@(unless (zerop position)
-		 `((:shrl ,position :ecx)))
-	     (:call-local-pf box-u32-ecx)
-	    done)))
-       (t form))))
-   (t form)))
 
 (defun ldb (bytespec integer)
   (ldb%byte (byte-size bytespec) (byte-position bytespec) integer))
 
-(define-compiler-macro ldb (&whole form &environment env bytespec integer)
-  (let ((bytespec (movitz::movitz-macroexpand bytespec env)))
-    (if (not (and (consp bytespec) (eq 'byte (car bytespec))))
-	form
-      `(ldb%byte ,(second bytespec) ,(third bytespec) ,integer))))
-
-(define-setf-expander ldb (bytespec int &environment env)
-  "Stolen from the Hyperspec example in the define-setf-expander entry."
-  (multiple-value-bind (temps vals stores store-form access-form)
-      (get-setf-expansion int env)	;Get setf expansion for int.
-    (let ((btemp (gensym))		;Temp var for byte specifier.
-	  (store (gensym))		;Temp var for byte to store.
-	  (stemp (first stores)))	;Temp var for int to store.
-      (if (cdr stores) (error "Can't expand this."))
-      ;; Return the setf expansion for LDB as five values.
-      (values (cons btemp temps)	;Temporary variables.
-	      (cons bytespec vals)	;Value forms.
-	      (list store)		;Store variables.
-	      `(let ((,stemp (dpb ,store ,btemp ,access-form)))
-		 ,store-form
-		 ,store)		;Storing form.
-	      `(ldb ,btemp ,access-form) ;Accessing form.
-              ))))
-
-
 (defun ldb-test (bytespec integer)
   (case (byte-size bytespec)
     (0 nil)
@@ -2456,14 +2055,6 @@
 		  r+1
 		r)))
 	 (setf r next-r))))))
-
-(define-compiler-macro expt (&whole form base-number power-number &environment env)
-  (if (not (and (movitz:movitz-constantp base-number env)
-		(movitz:movitz-constantp power-number env)))
-      form
-    (expt (movitz:movitz-eval base-number env)
-	  (movitz:movitz-eval power-number env))))
-    
 
 (defun expt (base-number power-number)
   "Take base-number to the power-number."




From ffjeld at common-lisp.net  Sat Jul 17 17:42:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 10:42:13 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BltCP-0002fs-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added operators %bignum-addf and %bignum-addf-fixnum.

Date: Sat Jul 17 10:42:11 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.71 movitz/losp/muerte/integers.lisp:1.72
--- movitz/losp/muerte/integers.lisp:1.71	Sat Jul 17 05:16:12 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 10:42:10 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.71 2004/07/17 12:16:12 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.72 2004/07/17 17:42:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -413,6 +413,84 @@
 	 (:xorl #xff00 (:eax #.movitz:+other-type-offset+)))))))
 
 ;;; Addition
+
+(defun %bignum-addf-fixnum (bignum delta)
+  "Destructively add a fixnum delta (negative or positive) to an (unsigned) bignum."
+  (check-type delta fixnum)
+  (check-type bignum bignum)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax :labels (add-bignum-loop add-bignum-done))
+	    (:load-lexical (:lexical-binding delta) :ecx)
+	    (:load-lexical (:lexical-binding bignum) :eax)
+	    (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ebx) ; length
+	    (:xorl :edx :edx)		; counter
+	    (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:jns 'positive-delta)
+	    ;; negative-delta
+	    (:negl :ecx)
+	    (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+	    (:jnc 'add-bignum-done)
+	   sub-bignum-loop
+	    (:addl 4 :edx)
+	    (:cmpl :edx :ebx)
+	    (:je '(:sub-program (overflow) (:int 4)))
+	    (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+	    (:jc 'sub-bignum-loop)
+	    (:jmp 'add-bignum-done)
+	    
+	   positive-delta
+	    (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+	    (:jnc 'add-bignum-done)
+	   add-bignum-loop
+	    (:addl 4 :edx)
+	    (:cmpl :edx :ebx)
+	    (:je '(:sub-program (overflow) (:int 4)))
+	    (:addl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+	    (:jc 'add-bignum-loop)
+	   add-bignum-done)))
+    (do-it)))
+
+(defun %bignum-addf (bignum delta)
+  "Destructively add (abs delta) to bignum."
+  (check-type bignum bignum)
+  (etypecase delta
+    (positive-fixnum
+     (%bignum-addf-fixnum bignum delta))
+    (negative-fixnum
+     (%bignum-addf-fixnum bignum (- delta)))
+    (bignum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	      not-size1
+	       (:load-lexical (:lexical-binding bignum) :eax) ; EAX = bignum
+	       (:load-lexical (:lexical-binding delta) :ebx) ;  EBX = delta
+	       (:xorl :edx :edx)	; Counter
+	       (:xorl :ecx :ecx)	; Carry
+	      add-bignum-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl (:ebx :edx (:offset movitz-bignum :bigit0))
+		      :ecx)
+	       (:jz 'carry+digit-overflowed) ; If CF=1, then ECX=0.
+	       (:addl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
+	      carry+digit-overflowed
+	       (:sbbl :ecx :ecx)
+	       (:negl :ecx)		; ECX = Add's Carry.
+	       (:addl 4 :edx)
+	       (:cmpw :dx (:ebx (:offset movitz-bignum length)))
+	       (:ja 'add-bignum-loop)
+	       ;; Now, if there's a carry we must propagate it.
+	       (:jecxz 'add-bignum-done)
+	      carry-propagate-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl 4 :edx)
+	       (:addl 1 (:eax :edx (:offset movitz-bignum bigit0 -4)))
+	       (:jc 'carry-propagate-loop)
+	      add-bignum-done)))
+       (do-it)))))
 
 (defun + (&rest terms)
   (declare (without-check-stack-limit))




From ffjeld at common-lisp.net  Sat Jul 17 19:30:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 12:30:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1Blusr-0005Zy-00@common-lisp.net>

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

Added Files:
	bignums.lisp 
Log Message:
Factored out bignum-related operators from integers.lisp to bignums.lisp.

Date: Sat Jul 17 12:30:09 2004
Author: ffjeld





From ffjeld at common-lisp.net  Sat Jul 17 19:30:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 12:30:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1Blusw-0006Eg-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
Factored out bignum-related operators from integers.lisp to bignums.lisp.

Date: Sat Jul 17 12:30:14 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.8 movitz/losp/muerte/common-lisp.lisp:1.9
--- movitz/losp/muerte/common-lisp.lisp:1.8	Sat Jul 17 05:16:08 2004
+++ movitz/losp/muerte/common-lisp.lisp	Sat Jul 17 12:30:14 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.8 2004/07/17 12:16:08 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.9 2004/07/17 19:30:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,6 +47,7 @@
 (require :muerte/streams)
 (require :muerte/restarts)
 (require :muerte/conditions)
+(require :muerte/bignums)
 (require :muerte/read)
 (require :muerte/interrupt)
 (require :muerte/scavenge)




From ffjeld at common-lisp.net  Sat Jul 17 19:30:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 12:30:20 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Blut2-0006gy-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Factored out bignum-related operators from integers.lisp to bignums.lisp.

Date: Sat Jul 17 12:30:20 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.72 movitz/losp/muerte/integers.lisp:1.73
--- movitz/losp/muerte/integers.lisp:1.72	Sat Jul 17 10:42:10 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 12:30:20 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.72 2004/07/17 17:42:10 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.73 2004/07/17 19:30:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,7 +23,6 @@
 (defconstant most-positive-fixnum #.movitz::+movitz-most-positive-fixnum+)
 (defconstant most-negative-fixnum #.movitz::+movitz-most-negative-fixnum+)
 
-
 ;;; Comparison
 
 (define-primitive-function fast-compare-two-reals (n1 n2)
@@ -413,84 +412,6 @@
 	 (:xorl #xff00 (:eax #.movitz:+other-type-offset+)))))))
 
 ;;; Addition
-
-(defun %bignum-addf-fixnum (bignum delta)
-  "Destructively add a fixnum delta (negative or positive) to an (unsigned) bignum."
-  (check-type delta fixnum)
-  (check-type bignum bignum)
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :eax :labels (add-bignum-loop add-bignum-done))
-	    (:load-lexical (:lexical-binding delta) :ecx)
-	    (:load-lexical (:lexical-binding bignum) :eax)
-	    (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ebx) ; length
-	    (:xorl :edx :edx)		; counter
-	    (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
-	    (:jns 'positive-delta)
-	    ;; negative-delta
-	    (:negl :ecx)
-	    (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-	    (:jnc 'add-bignum-done)
-	   sub-bignum-loop
-	    (:addl 4 :edx)
-	    (:cmpl :edx :ebx)
-	    (:je '(:sub-program (overflow) (:int 4)))
-	    (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-	    (:jc 'sub-bignum-loop)
-	    (:jmp 'add-bignum-done)
-	    
-	   positive-delta
-	    (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-	    (:jnc 'add-bignum-done)
-	   add-bignum-loop
-	    (:addl 4 :edx)
-	    (:cmpl :edx :ebx)
-	    (:je '(:sub-program (overflow) (:int 4)))
-	    (:addl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-	    (:jc 'add-bignum-loop)
-	   add-bignum-done)))
-    (do-it)))
-
-(defun %bignum-addf (bignum delta)
-  "Destructively add (abs delta) to bignum."
-  (check-type bignum bignum)
-  (etypecase delta
-    (positive-fixnum
-     (%bignum-addf-fixnum bignum delta))
-    (negative-fixnum
-     (%bignum-addf-fixnum bignum (- delta)))
-    (bignum
-     (macrolet
-	 ((do-it ()
-	    `(with-inline-assembly (:returns :eax)
-	      not-size1
-	       (:load-lexical (:lexical-binding bignum) :eax) ; EAX = bignum
-	       (:load-lexical (:lexical-binding delta) :ebx) ;  EBX = delta
-	       (:xorl :edx :edx)	; Counter
-	       (:xorl :ecx :ecx)	; Carry
-	      add-bignum-loop
-	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
-	       (:jbe '(:sub-program (overflow) (:int 4)))
-	       (:addl (:ebx :edx (:offset movitz-bignum :bigit0))
-		      :ecx)
-	       (:jz 'carry+digit-overflowed) ; If CF=1, then ECX=0.
-	       (:addl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
-	      carry+digit-overflowed
-	       (:sbbl :ecx :ecx)
-	       (:negl :ecx)		; ECX = Add's Carry.
-	       (:addl 4 :edx)
-	       (:cmpw :dx (:ebx (:offset movitz-bignum length)))
-	       (:ja 'add-bignum-loop)
-	       ;; Now, if there's a carry we must propagate it.
-	       (:jecxz 'add-bignum-done)
-	      carry-propagate-loop
-	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
-	       (:jbe '(:sub-program (overflow) (:int 4)))
-	       (:addl 4 :edx)
-	       (:addl 1 (:eax :edx (:offset movitz-bignum bigit0 -4)))
-	       (:jc 'carry-propagate-loop)
-	      add-bignum-done)))
-       (do-it)))))
 
 (defun + (&rest terms)
   (declare (without-check-stack-limit))




From ffjeld at common-lisp.net  Sat Jul 17 19:32:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 12:32:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Bluuv-0001dD-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Moved some operators to bignums.lisp.

Date: Sat Jul 17 12:32:16 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.24 movitz/losp/muerte/inspect.lisp:1.25
--- movitz/losp/muerte/inspect.lisp:1.24	Fri Jul 16 18:52:29 2004
+++ movitz/losp/muerte/inspect.lisp	Sat Jul 17 12:32:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.24 2004/07/17 01:52:29 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.25 2004/07/17 19:32:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -258,74 +258,3 @@
 	      #.(movitz::movitz-type-word-size :movitz-struct)
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
-(defun %bignum-bigits (x)
-  (%bignum-bigits x))
-
-(defun %bignum-canonicalize (x)
-  "Assuming x is a bignum, return the canonical integer value. That is,
-either return a fixnum, or destructively modify the bignum's length so
-that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
-  (check-type x bignum)
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :eax)
-	    (:load-lexical (:lexical-binding x) :eax)
-	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-	    (:shrl 16 :ecx)
-	    (:jz '(:sub-program (should-never-happen)
-		   (:int 107)))
-	   shrink-loop
-	    (:cmpl 4 :ecx)
-	    (:je 'shrink-no-more)
-	    (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
-	    (:jnz 'shrink-done)
-	    (:subl 4 :ecx)
-	    (:jmp 'shrink-loop)
-	   shrink-no-more
-	    (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+)
-		   (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-	    (:jc '(:sub-program (fixnum-result)
-		   (:movl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		    :ecx)
-		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
-		   (:jmp 'done)))
-	   shrink-done
-	    (:testb 3 :cl)
-	    (:jnz '(:sub-program () (:int 107)))
-	    (:testw :cx :cx)
-	    (:jz '(:sub-program () (:int 107)))
-	    (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
-	   done
-	    )))
-    (do-it)))
-
-(defun copy-bignum (old)
-  (check-type old bignum)
-  (let* ((length (%bignum-bigits old))
-	 (new (malloc-non-pointer-words (1+ length))))
-    (with-inline-assembly (:returns :eax)
-      (:compile-two-forms (:eax :ebx) new old)
-      (:compile-form (:result-mode :edx) length)
-     copy-bignum-loop
-      (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx)
-      (:movl :ecx (:eax :edx #.movitz:+other-type-offset+))
-      (:subl 4 :edx)
-      (:jnc 'copy-bignum-loop))))
-
-(defun %make-bignum (bigits)
-  (assert (plusp bigits))
-  (macrolet
-      ((do-it ()
-	 `(with-inline-assembly (:returns :eax)
-	    (:compile-two-forms (:eax :ecx) (malloc-non-pointer-words (1+ bigits)) bigits)
-	    (:shll 16 :ecx)
-	    (:orl ,(movitz:tag :bignum 0) :ecx)
-	    (:movl :ecx (:eax ,movitz:+other-type-offset+)))))
-    (do-it)))
-
-(defun print-bignum (x)
-  (check-type x bignum)
-  (dotimes (i (1+ (%bignum-bigits x)))
-    (format t "~8,'0X " (memref x -6 i :unsigned-byte32)))
-  (terpri)
-  (values))




From ffjeld at common-lisp.net  Sat Jul 17 21:27:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 14:27:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1BlwiD-0004p2-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
*** empty log message ***
Date: Sat Jul 17 14:27:16 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.9 movitz/losp/muerte/common-lisp.lisp:1.10
--- movitz/losp/muerte/common-lisp.lisp:1.9	Sat Jul 17 12:30:14 2004
+++ movitz/losp/muerte/common-lisp.lisp	Sat Jul 17 14:27:16 2004
@@ -9,12 +9,11 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.9 2004/07/17 19:30:14 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.10 2004/07/17 21:27:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (require :muerte/basic-macros)
-
 (require :muerte/setf)
 (require :muerte/more-macros)
 (require :muerte/arithmetic-macros)




From ffjeld at common-lisp.net  Sat Jul 17 21:36:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 14:36:35 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlwrD-0004fY-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Changed assembly stubs to use :offset assembly-macro.

Date: Sat Jul 17 14:36:34 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.73 movitz/losp/muerte/integers.lisp:1.74
--- movitz/losp/muerte/integers.lisp:1.73	Sat Jul 17 12:30:20 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 14:36:34 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.73 2004/07/17 19:30:20 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.74 2004/07/17 21:36:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,7 +65,7 @@
 	    (:cmpb ,(movitz:tag :bignum) :cl)
 	    (:jne 'n2-not-bignum)
 
-	    (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign)))
+	    (:cmpb :ch (:eax (:offset movitz-bignum sign)))
 	    (:jne '(:sub-program (different-signs)
 		    ;; Comparing the sign-bytes sets up EFLAGS correctly!
 		    (:ret)))
@@ -74,7 +74,7 @@
 	    ;; Both n1 and n2 are positive bignums.
 
 	    (:shrl 16 :ecx)
-	    (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
+	    (:cmpw :cx (:eax (:offset movitz-bignum length)))
 	    (:jne '(:sub-program (positive-different-sizes)
 		    (:ret)))
 
@@ -83,25 +83,21 @@
 	   positive-compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'positive-compare-lsb)
-	    (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:movl (:ebx :edx (:offset movitz-bignum bigit0)) :ecx)
+	    (:cmpl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 	    (:je 'positive-compare-loop)
 	   positive-compare-lsb
 	    ;; Now we have to make the compare act as unsigned, which is why
 	    ;; we compare zero-extended 16-bit quantities.
-	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)		; First compare upper 16 bits.
+	    (:movzxw (:ebx :edx (:offset movitz-bignum bigit0 2)) :ecx) ; First compare upper 16 bits.
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)
+	    (:movzxw (:eax :edx (:offset movitz-bignum bigit0 2)) :ecx)
 	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
 	    (:jne 'upper-16-decisive)
-	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+	    (:movzxw (:ebx :edx (:offset movitz-bignum bigit0))
 		     :ecx)		; Then compare lower 16 bits.
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+	    (:movzxw (:eax :edx (:offset movitz-bignum bigit0))
 		     :ecx)		; Then compare lower 16 bits.
 	    (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx))
 	   upper-16-decisive
@@ -111,7 +107,7 @@
 	    ;; Moth n1 and n2 are negative bignums.
 
 	    (:shrl 16 :ecx)
-	    (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx)
+	    (:cmpw (:eax (:offset movitz-bignum length)) :cx)
 	    (:jne '(:sub-program (negative-different-sizes)
 		    (:ret)))
 
@@ -120,26 +116,23 @@
 	   negative-compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'negative-compare-lsb)
-	    (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:movl (:eax :edx (:offset movitz-bignum bigit0)) :ecx)
+	    (:cmpl :ecx (:ebx :edx (:offset movitz-bignum bigit0)))
 	    (:je 'negative-compare-loop)
 	    (:ret)
 	   negative-compare-lsb		; it's down to the LSB bigits.
 	    ;; Now we have to make the compare act as unsigned, which is why
 	    ;; we compare zero-extended 16-bit quantities.
-	    (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	    (:movzxw (:ebx :edx (:offset movitz-bignum bigit0 2))
 		     :ecx)		; First compare upper 16 bits.
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     :ecx)
+	    (:movzxw (:eax :edx (:offset movitz-bignum bigit0)) :ecx)
 	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
 	    (:jne 'negative-upper-16-decisive)
-	    (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+	    (:movzxw (:ebx :edx (:offset movitz-bignum bigit0))
 		     :ecx)		; Then compare lower 16 bits.
 	    (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
-	    (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+	    (:movzxw (:eax :edx (:offset movitz-bignum bigit0))
 		     :ecx)		; Then compare lower 16 bits.
 	    (:locally (:cmpl :ecx (:edi (:edi-offset scratch0))))
 	   negative-upper-16-decisive
@@ -171,10 +164,8 @@
 	   compare-loop
 	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
 	    (:jz 'done)
-	    (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		   :ecx)
-	    (:cmpl :ecx
-		   (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+	    (:movl (:eax :edx (:offset movitz-bignum bigit0 -4)) :ecx)
+	    (:cmpl :ecx (:ebx :edx (:offset movitz-bignum bigit0 -4)))
 	    (:je 'compare-loop)
 	   done
 	    (:ret))))
@@ -459,18 +450,18 @@
 		   (:compile-two-forms (:eax :ebx) y x)
 		   (:testl :ebx :ebx)
 		   (:jz 'pfix-pbig-done)
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		   (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
 		   (:jne 'not-size1)
 		   (:compile-form (:result-mode :ecx) x)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
-		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		   (:addl (:eax (:offset movitz-bignum bigit0)) :ecx)
 		   (:jc 'retry-not-size1)
 		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'pfix-pbig-done)
 		  retry-not-size1
 		   (:compile-form (:result-mode :eax) y)
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		  not-size1
 		   (:declare-label-set retry-jumper (retry-not-size1))
 		   (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
@@ -481,7 +472,7 @@
 			  :eax)		; Number of words
 		   (:call-local-pf get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
-		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :edx)
 		   (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
@@ -494,18 +485,16 @@
 		   (:load-lexical (:lexical-binding x) :ecx)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:xorl :ebx :ebx)
-		   (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:addl :ecx (:eax (:offset movitz-bignum bigit0)))
 		   (:jnc 'add-bignum-done)
 		  add-bignum-loop
 		   (:addl 4 :ebx)
-		   (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:addl 1 (:eax :ebx (:offset movitz-bignum bigit0)))
 		   (:jc 'add-bignum-loop)
 		  add-bignum-done
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
-			    :ecx)
-		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
-			  :ecx)
-		   (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		   (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
+		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) :ecx)
+		   (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -4)))
 		   (:je 'no-expansion)
 		   (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
@@ -526,17 +515,17 @@
 							       no-expansion
 							       pfix-pbig-done))
 		   (:compile-two-forms (:eax :ebx) y x)
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		   (:cmpl 4 :ecx)
 		   (:jne 'not-size1)
 		   (:compile-form (:result-mode :ecx) x)
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
-		   (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		   (:addl (:eax (:offset movitz-bignum bigit0)) :ecx)
 		   (:call-local-pf box-u32-ecx)
 		   (:jmp 'pfix-pbig-done)
 		  retry-not-size1
 		   (:compile-form (:result-mode :eax) y)
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		  not-size1
 		   (:declare-label-set retry-jumper (retry-not-size1))
 		   (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
@@ -547,7 +536,7 @@
 			  :eax)		; Number of words
 		   (:call-local-pf get-cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
-		   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		   (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :edx)
 		  copy-bignum-loop
@@ -560,18 +549,18 @@
 		   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:xorl :ebx :ebx)	; counter
 		   (:negl :ecx)
-		   (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:subl :ecx (:eax (:offset movitz-bignum bigit0)))
 		   (:jnc 'add-bignum-done)
 		  add-bignum-loop
 		   (:addl 4 :ebx)
-		   (:subl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		   (:subl 1 (:eax :ebx (:offset movitz-bignum bigit0)))
 		   (:jc 'add-bignum-loop)
 		  add-bignum-done
-		   (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		   (:movzxw (:eax (:offset movitz-bignum length))
 			    :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			  :ecx)		; result bignum word-size
-		   (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		   (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -8)))
 		   (:jne 'no-expansion)
 		   (:subl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
@@ -595,17 +584,17 @@
 		     (:compile-two-forms (:eax :ebx) y x)
 		     (:testl :ebx :ebx)
 		     (:jz 'pfix-pbig-done)
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		     (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
 		     (:jne 'not-size1)
-		     (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
-		     (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx)
+		     (:movl (:ebx (:offset movitz-bignum bigit0)) :ecx)
+		     (:addl (:eax (:offset movitz-bignum bigit0)) :ecx)
 		     (:jc 'retry-not-size1)
 		     (:call-local-pf box-u32-ecx)
 		     (:jmp 'pfix-pbig-done)
 		    retry-not-size1
 		     (:compile-form (:result-mode :eax) y)
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
 		    not-size1
 		     (:declare-label-set retry-jumper (retry-not-size1))
 		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
@@ -616,7 +605,7 @@
 			    :eax)	; Number of words
 		     (:call-local-pf get-cons-pointer)
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+		     (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :edx)
 		     (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
@@ -630,37 +619,37 @@
 		     (:xorl :edx :edx)	; counter
 		     (:xorl :ecx :ecx)	; Carry
 		    add-bignum-loop
-		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :dx (:ebx (:offset movitz-bignum length)))
 		     (:jbe '(:sub-program (zero-padding-loop)
-			     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum
-						      'movitz::bigit0)))
+			     (:addl :ecx (:eax :edx (:offset movitz-bignum
+						      bigit0)))
 			     (:sbbl :ecx :ecx)
 			     (:negl :ecx) ; ECX = Add's Carry.
 			     (:addl 4 :edx)
-			     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			     (:cmpw :dx (:eax (:offset movitz-bignum length)))
 			     (:jae 'zero-padding-loop)
 			     (:jmp 'add-bignum-done)))
-		     (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		     (:addl (:ebx :edx (:offset movitz-bignum bigit0))
 			    :ecx)
 		     (:jc '(:sub-program (term1-carry)
 			    ;; The digit + carry carried over, ECX = 0
 			    (:addl 1 :ecx)
 			    (:addl 4 :edx)
-			    (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			    (:cmpw :dx (:eax (:offset movitz-bignum length)))
 			    (:jae 'add-bignum-loop)
 			    (:jmp 'add-bignum-done)))
-		     (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:addl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 		     (:sbbl :ecx :ecx)
 		     (:negl :ecx)	; ECX = Add's Carry.
 		     (:addl 4 :edx)
-		     (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :dx (:eax (:offset movitz-bignum length)))
 		     (:jae 'add-bignum-loop)
 		    add-bignum-done
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:eax (:offset movitz-bignum length))
 			      :ecx)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
-		     (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -4)))
 		     (:je 'no-expansion)
 		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
@@ -712,8 +701,7 @@
 			(:jne 'not-a-number)
 			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
 			(:jne 'not-most-negative-fixnum)
-			(:cmpl ,(- most-negative-fixnum)
-			 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:cmpl ,(- most-negative-fixnum) (:eax (:offset movitz-bignum bigit0)))
 			(:jne 'not-most-negative-fixnum)
 			(:movl ,(ldb (byte 32 0)
 				 (* most-negative-fixnum movitz::+movitz-fixnum-factor+))
@@ -722,7 +710,7 @@
 			not-most-negative-fixnum
 			(:compile-form (:result-mode :eax)
 			 (copy-bignum x))
-			(:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)))
+			(:notb (:eax (:offset movitz-bignum sign)))
 			(:jmp 'fix-ok)))
 		(:negl :eax)
 		(:jo '(:sub-program (fix-overflow)
@@ -762,28 +750,26 @@
 			(:xorl :edx :edx) ; counter
 			(:xorl :ecx :ecx) ; carry
 		       sub-loop
-			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			(:addl (:ebx :edx (:offset movitz-bignum bigit0))
 			       :ecx)
 			(:jc '(:sub-program (carry-overflow)
 			       ;; Just propagate carry
 			       (:addl 1 :ecx)
 			       (:addl 4 :edx)
-			       (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			       (:cmpw :dx (:ebx (:offset movitz-bignum length)))
 			       (:jne 'sub-loop)
 			       (:jmp 'bignum-sub-done)))
-			(:subl :ecx
-			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:subl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 			(:sbbl :ecx :ecx)
 			(:negl :ecx)
 			(:addl 4 :edx)
-			(:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			(:cmpw :dx (:ebx (:offset movitz-bignum length)))
 			(:jne 'sub-loop)
-			(:subl :ecx
-			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:subl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 			(:jnc 'bignum-sub-done)
 		       propagate-carry
 			(:addl 4 :edx)
-			(:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:subl 1 (:eax :edx (:offset movitz-bignum bigit0)))
 			(:jc 'propagate-carry)
 		       bignum-sub-done
 			)))))
@@ -950,11 +936,11 @@
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
 	       (:compile-form (:result-mode :ebx) integer)
-	       (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
+	       (:movzxw (:ebx (:offset movitz-bignum length))
 			:ecx)
 	       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
 		      :eax)		; bigits-1
-	       (:bsrl (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	       (:bsrl (:ebx (:ecx 1) (:offset movitz-bignum bigit0 -4))
 		      :ecx)
 	       (:shll 5 :eax)		; bits = bigits*32 + (bit-index+1)
 	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax
@@ -998,21 +984,21 @@
 				  (byte 16 16) (movitz:tag :bignum 0))
 			    (:eax ,movitz:+other-type-offset+))
 		     (:load-lexical (:lexical-binding d0) :ecx)
-		     (:movl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:movl :ecx (:eax (:offset movitz-bignum bigit0)))
 		     (:load-lexical (:lexical-binding d1) :ecx)
 		     (:sarl ,movitz:+movitz-fixnum-shift+
 			    :ecx)
 		     (:shrdl ,movitz:+movitz-fixnum-shift+ :ecx
-			     (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			     (:eax (:offset movitz-bignum bigit0)))
 		     (:sarl ,movitz:+movitz-fixnum-shift+
 			    :ecx)
-		     (:movl :ecx (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:movl :ecx (:eax (:offset movitz-bignum bigit0 4)))
 		     (:jns 'fixnum-done)
 		     ;; if result was negative, we must negate bignum
-		     (:notl (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
-		     (:negl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:notl (:eax (:offset movitz-bignum bigit0 4)))
+		     (:negl (:eax (:offset movitz-bignum bigit0)))
 		     (:cmc)
-		     (:adcl 0 (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:adcl 0 (:eax (:offset movitz-bignum bigit0 4)))
 		     (:xorl #xff00 (:eax ,movitz:+other-type-offset+))
 		     (:jmp 'fixnum-done)
 		     
@@ -1053,7 +1039,7 @@
 				      (:edi (:edi-offset atomically-status))))
 			     
 		     (:compile-form (:result-mode :eax) y)
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:eax (:offset movitz-bignum length))
 			      :ecx)
 		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 			    :eax)
@@ -1074,28 +1060,23 @@
 		     (:negl :esi)	; can't overflow
 		    multiply-loop
 		     (:movl :edx (:ebx (:ecx 1) ; new
-				       ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+				       (:offset movitz-bignum bigit0)))
 		     (:compile-form (:result-mode :ebx) y)
-		     (:movl (:ebx (:ecx 1) ; old
-				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		     (:movl (:ebx (:ecx 1) (:offset movitz-bignum bigit0))
 			    :eax)
 		     
 		     (:mull :esi :eax :edx)
 		     (:compile-form (:result-mode :ebx) r)
-		     (:addl :eax
-			    (:ebx (:ecx 1)
-				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:addl :eax (:ebx :ecx (:offset movitz-bignum bigit0)))
 		     (:adcl 0 :edx)
 		     (:addl 4 :ecx)
-		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :cx (:ebx (:offset movitz-bignum length)))
 		     (:ja 'multiply-loop)
 		     (:testl :edx :edx)
 		     (:jz 'no-carry-expansion)
-		     (:movl :edx
-			    (:ebx (:ecx 1)
-				  ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		     (:movl :edx (:ebx :ecx (:offset movitz-bignum bigit0)))
 		     (:addl 4 :ecx)
-		     (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:movw :cx (:ebx (:offset movitz-bignum length)))
 		    no-carry-expansion
 		     (:movl (:ebp -4) :esi)
 		     (:movl :ebx :eax)
@@ -1167,12 +1148,12 @@
 		   (with-inline-assembly (:returns :multiple-values)
 		     (:compile-form (:result-mode :ebx) number)
 		     (:cmpw ,movitz:+movitz-fixnum-factor+
-			    (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			    (:ebx (:offset movitz-bignum length)))
 		     (:jne 'not-size1)
 		     (:compile-form (:result-mode :ecx) divisor)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		     (:std)
-		     (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax)
+		     (:movl (:ebx (:offset movitz-bignum bigit0)) :eax)
 		     (:xorl :edx :edx)
 		     (:divl :ecx :eax :edx)
 		     (:movl :eax :ecx)
@@ -1185,7 +1166,7 @@
 		     (:jmp 'done)
 		    not-size1
 		     (:compile-form (:result-mode :ebx) number)
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :ecx)
 	     
 		     (:declare-label-set retry-jumper (not-size1))
@@ -1212,13 +1193,11 @@
 
 		    divide-loop
 		     (:load-lexical (:lexical-binding number) :ebx)
-		     (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
-				  -4 (:ecx 1))
+		     (:movl (:ebx :ecx (:offset movitz-bignum bigit0 -4))
 			    :eax)
 		     (:divl :esi :eax :edx)
 		     (:load-lexical (:lexical-binding r) :ebx)
-		     (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
-				       -4 (:ecx 1)))
+		     (:movl :eax (:ebx :ecx (:offset movitz-bignum bigit0 -4)))
 		     (:subl 4 :ecx)
 		     (:jnz 'divide-loop)
 		     (:movl :edi :eax)	; safe value
@@ -1228,21 +1207,21 @@
 		     (:movl :ebx :eax)
 		     (:movl :edx :ebx)
 
-		     (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:eax (:offset movitz-bignum length))
 			      :ecx)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
-		     (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+		     (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -8)))
 		     (:jne 'no-more-shrinkage)
 		     
-		     (:subw 4 (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:subw 4 (:eax (:offset movitz-bignum length)))
 		     (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		     (:cmpl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx)
 		     (:jne 'no-more-shrinkage)
 		     (:cmpl ,movitz:+movitz-most-positive-fixnum+
-			    (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			    (:eax (:offset movitz-bignum bigit0)))
 		     (:jnc 'no-more-shrinkage)
-		     (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		     (:movl (:eax (:offset movitz-bignum bigit0))
 			    :ecx)
 		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		     (:jmp 'fixnum-result) ; don't commit the bignum
@@ -1396,7 +1375,7 @@
 	     (with-inline-assembly (:returns :boolean-cf=1)
 	       (:compile-two-forms (:ecx :ebx) index integer)
 	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
-	       (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))))
+	       (:btl :ecx (:ebx (:offset movitz-bignum bigit0))))))))
     (do-it)))
 
 (defun logand (&rest integers)
@@ -1430,14 +1409,14 @@
 		   (%bignum-canonicalize
 		    (with-inline-assembly (:returns :eax)
 		      (:compile-two-forms (:eax :ebx) (copy-bignum x) y)
-		      (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		      (:movzxw (:eax (:offset movitz-bignum length))
 			       :ecx)
 		      (:leal ((:ecx 1) -4) :edx)
 		     pb-pb-and-loop
-		      (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		      (:movl (:ebx :edx (:offset movitz-bignum bigit0))
 			     :ecx)
 		      (:andl :ecx
-			     (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			     (:eax :edx (:offset movitz-bignum bigit0)))
 		      (:subl 4 :edx)
 		      (:jnc 'pb-pb-and-loop)))))
 		)))
@@ -1468,21 +1447,19 @@
 		(:compile-two-forms (:eax :ecx) (copy-bignum integer2) integer1)
 		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		(:notl :ecx)
-		(:andl :ecx
-		       (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))))
+		(:andl :ecx (:eax (:offset movitz-bignum bigit0))))))
 	    ((positive-bignum positive-bignum)
 	     (%bignum-canonicalize
 	      (with-inline-assembly (:returns :eax)
 		(:compile-two-forms (:eax :ebx) (copy-bignum integer2) integer1)
-		(:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		(:movzxw (:eax (:offset movitz-bignum length))
 			 :ecx)
 		(:leal ((:ecx 1) -4) :edx)
 	       pb-pb-andc1-loop
-		(:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		(:movl (:ebx :edx (:offset movitz-bignum bigit0))
 		       :ecx)
 		(:notl :ecx)
-		(:andl :ecx
-		       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		(:andl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 		(:subl 4 :edx)
 		(:jnc 'pb-pb-andc1-loop)))))))
     (do-it)))
@@ -1507,7 +1484,7 @@
 		   (with-inline-assembly (:returns :eax)
 		     (:compile-two-forms (:eax :ecx) r x)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		     (:orl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))))
+		     (:orl :ecx (:eax (:offset movitz-bignum bigit0)))))))
 	   (do-it)))
 	((positive-bignum positive-fixnum)
 	 (macrolet
@@ -1516,7 +1493,7 @@
 		   (with-inline-assembly (:returns :eax)
 		     (:compile-two-forms (:eax :ecx) r y)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		     (:orl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))))
+		     (:orl :ecx (:eax (:offset movitz-bignum bigit0)))))))
 	   (do-it)))
 	((positive-bignum positive-bignum)
 	 (if (< (%bignum-bigits x) (%bignum-bigits y))
@@ -1526,15 +1503,15 @@
 		 ((do-it ()
 		    `(with-inline-assembly (:returns :eax)
 		       (:compile-two-forms (:eax :ebx) r y)
-		       (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		       (:movzxw (:ebx (:offset movitz-bignum length))
 				:ecx)
 		       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
 			      :edx)	; EDX is loop counter
 		      or-loop
-		       (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		       (:movl (:ebx :edx (:offset movitz-bignum bigit0))
 			      :ecx)
 		       (:orl :ecx
-			     (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			     (:eax :edx (:offset movitz-bignum bigit0)))
 		       (:subl 4 :edx)
 		       (:jnc 'or-loop))))
 	       (do-it)))))))
@@ -1561,8 +1538,7 @@
 		`(with-inline-assembly (:returns :eax)
 		   (:compile-two-forms (:eax :ecx) (copy-bignum y) x)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		   (:xorl :ecx
-			  (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))
+		   (:xorl :ecx (:eax (:offset movitz-bignum bigit0))))))
 	   (do-it)))
 	((positive-bignum positive-fixnum)
 	 (macrolet
@@ -1570,8 +1546,7 @@
 		`(with-inline-assembly (:returns :eax)
 		   (:compile-two-forms (:eax :ecx) (copy-bignum x) y)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
-		   (:xorl :ecx
-			  (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))
+		   (:xorl :ecx (:eax (:offset movitz-bignum bigit0))))))
 	   (do-it)))
 	((positive-bignum positive-bignum)
 	 (if (< (%bignum-bigits x) (%bignum-bigits y))
@@ -1582,15 +1557,14 @@
 		    `(%bignum-canonicalize
 		      (with-inline-assembly (:returns :eax)
 			(:compile-two-forms (:eax :ebx) r y)
-			(:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			(:movzxw (:ebx (:offset movitz-bignum length))
 				 :ecx)
 			(:leal ((:ecx 1),(* -1 movitz:+movitz-fixnum-factor+))
 			       :edx)	; EDX is loop counter
 		       xor-loop
-			(:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+			(:movl (:ebx :edx (:offset movitz-bignum bigit0))
 			       :ecx)
-			(:xorl :ecx
-			       (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			(:xorl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 			(:subl 4 :edx)
 			(:jnc 'xor-loop)
 			))))
@@ -1666,15 +1640,14 @@
 	       ;; Have fresh bignum in EAX, now fill it with ones.
 	       (:xorl :ecx :ecx)	; counter
 	      fill-ones-loop
-	       (:movl #xffffffff
-		      (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	       (:movl #xffffffff (:eax :ecx (:offset movitz-bignum bigit0)))
 	       (:addl 4 :ecx)
-	       (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
+	       (:cmpw :cx (:eax (:offset movitz-bignum length)))
 	       (:jne 'fill-ones-loop)
 	       
 	       (:popl :ecx)		; The LSB bigit.
 	       (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
-	       (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+	       (:movl :ecx (:eax (:offset movitz-bignum bigit0)))
 	       (:movl :eax :ebx)
 	       ;; Compute MSB bigit mask in EDX
 	       (:compile-form (:result-mode :ecx) size)
@@ -1687,10 +1660,10 @@
 	       (:shll :cl :edx)
 	      fixnum-mask-ok
 	       (:subl 1 :edx)
-	       (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
+	       (:movzxw (:ebx (:offset movitz-bignum length))
 			:ecx)
 	       (:andl :edx		; And EDX with the MSB bigit.
-		      (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+		      (:ebx :ecx (:offset movitz-bignum bigit0 -4)))
 	       (:movl :edi :edx)
 	       (:movl :edi :eax)
 	       (:cld)			; =================> CLD
@@ -1723,17 +1696,17 @@
 		 (:addl 4 :ecx)
 		 (:cmpl #x4000 :ecx)
 		 (:jae 'position-outside-integer)
-		 (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		 (:cmpw :cx (:ebx (:offset movitz-bignum length)))
 		 (:jc '(:sub-program (position-outside-integer)
-			(:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx)
+			(:movsxb (:ebx (:offset movitz-bignum sign)) :ecx)
 			(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 			(:jmp 'done-u32)))
 		 (:std)
-		 (:movl (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		 (:movl (:ebx :ecx (:offset movitz-bignum bigit0 -4))
 			:eax)
 		 (:movl 0 :edx)		; If position was in last bigit.. (don't touch EFLAGS)
 		 (:je 'no-top-bigit)	; ..we must zero-extend rather than read top bigit.
-		 (:movl (:ebx (:ecx 1) ,(+ 0 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		 (:movl (:ebx :ecx (:offset movitz-bignum bigit0))
 			:edx)		; Read top bigit into EDX
 		no-top-bigit
 		 (:testl #xff00 (:ebx ,movitz:+other-type-offset+))
@@ -1765,7 +1738,7 @@
 			      (byte 16 16) (movitz:tag :bignum 0))
 			(:ebx ,movitz:+other-type-offset+))			     
 		 (:jne 'cant-return-same)
-		 (:cmpl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		 (:cmpl :ecx (:ebx (:offset movitz-bignum bigit0)))
 		 (:jne 'cant-return-same)
 		 (:movl :ebx :eax)
 		 (:jmp 'done-u32)
@@ -1783,9 +1756,9 @@
 		     (:shrl 5 :ecx) ; compute fixnum bigit-number in ecx
 		     (:cmpl #x4000 :ecx)
 		     (:jnc 'position-outside-integer)
-		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :cx (:ebx (:offset movitz-bignum length)))
 		     (:jbe '(:sub-program (position-outside-integer)
-			     (:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx)
+			     (:movsxb (:ebx (:offset movitz-bignum sign)) :ecx)
 			     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 			     (:jmp 'done-u32)))
 		     
@@ -1795,7 +1768,7 @@
 		     (:into)		; just to make sure
 		     (:shrl 5 :ecx)	; compute msb bigit index/fixnum in ecx
 		     (:addl 4 :ecx)
-		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :cx (:ebx (:offset movitz-bignum length)))
 		     (je '(:sub-program (equal-size-maybe-return-same)
 			   (:testl :edx :edx) ; Can only return same if (zerop position).
 			   (:jnz 'adjust-size)
@@ -1807,10 +1780,9 @@
 			   ;; we know EDX=0, now generate mask in EDX
 			   (:addl 1 :edx)
 			   (:shll :cl :edx)
-			   (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+			   (:movzxw (:ebx (:offset movitz-bignum length))
 			    :ecx)
-			   (:cmpl :edx (:ebx (:ecx 1)
-					,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+			   (:cmpl :edx (:ebx :ecx (:offset movitz-bignum bigit0 -4)))
 			   (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size.
 			   (:cld)	; =================>
 			   (:jnc 'adjust-size) ; nope, we have to generate a new bignum.
@@ -1827,7 +1799,7 @@
 		    adjust-size
 		     ;; The bytespec is (partially) outside source-integer, so we make the
 		     ;; size smaller before proceeding. new-size = (- source-int-length position)
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :ecx)	; length of source-integer
 		     (:shll 5 :ecx)	; fixnum bit-position
 		     (:xorl :eax :eax)	; In case the new size is zero.
@@ -1868,37 +1840,36 @@
 		     
 		     ;; Edge case: When size(old)=size(new), the tail-tmp must be zero.
 		     ;; We check here, setting the tail-tmp to a mask for and-ing below.
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :ecx)	; length of source-integer
 		     ;; Initialize tail-tmp to #xffffffff, meaning copy from source-integer.
-		     (:movl #xffffffff
-			    (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
-		     (:cmpw :cx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:movl #xffffffff (:ebx :ecx (:offset movitz-bignum bigit0)))
+		     (:cmpw :cx (:eax (:offset movitz-bignum length)))
 		     (:jc '(:sub-program (result-too-big-shouldnt-happen)
 			    (:break)))
 		     (:jne 'tail-tmp-ok)
 		     ;; Sizes was equal, so set tail-tmp to zero.
-		     (:movl 0 (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:movl 0 (:ebx :ecx (:offset movitz-bignum bigit0)))
 		    tail-tmp-ok
 		     ;; Now copy the relevant part of the integer
 		     (:std)
 		     (:compile-form (:result-mode :ecx) position)
 		     (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx
 		     ;; We can use primitive pointers because we're both inside atomically and std.
-		     (:leal (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     (:leal (:eax (:ecx 4) (:offset movitz-bignum bigit0))
 			    :eax)	; Use EAX as primitive pointer into source
 		     (:xorl :ecx :ecx)	; counter
 		    copy-integer
 		     (:movl (:eax) :edx)
 		     (:addl 4 :eax)
-		     (:movl :edx (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:movl :edx (:ebx :ecx (:offset movitz-bignum bigit0)))
 		     (:addl 4 :ecx)
-		     (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :cx (:ebx (:offset movitz-bignum length)))
 		     (:jne 'copy-integer)
 		     ;; Copy one more than the length, namely the tmp at the end.
 		     ;; Tail-tmp was initialized to a bit-mask above.
 		     (:movl (:eax) :edx)
-		     (:andl :edx (:ebx (:ecx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:andl :edx (:ebx :ecx (:offset movitz-bignum bigit0)))
 		     ;; Copy done, now shift
 		     (:compile-form (:result-mode :ecx) position)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -1906,16 +1877,16 @@
 		     (:jz 'shift-done)	; if (zerop (mod position 32)), no shift needed.
 		     (:xorl :edx :edx)	; counter
 		    shift-loop
-		     (:movl (:ebx (:edx 1) ,(+ 4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		     (:movl (:ebx :edx (:offset movitz-bignum bigit0 4))
 			    :eax)	; Next bigit into eax
 		     (:shrdl :cl :eax	; Now shift bigit, with msbs from eax.
-			     (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			     (:ebx :edx (:offset movitz-bignum bigit0)))
 		     (:addl 4 :edx)
-		     (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:cmpw :dx (:ebx (:offset movitz-bignum length)))
 		     (:jne 'shift-loop)
 		    shift-done
 		     ;; Now we must mask MSB bigit.
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :edx)
 		     (:popl :ecx)	; (new) bytespec size
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -1924,18 +1895,16 @@
 		     (:movl 1 :eax)	; Generate mask in EAX
 		     (:shll :cl :eax)
 		     (:subl 1 :eax)
-		     (:andl :eax
-			    (:ebx (:edx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+		     (:andl :eax (:ebx :edx (:offset movitz-bignum bigit0 -4)))
 		    mask-done
 		     ;; (:movl :edi :edx)	; safe EDX
 		     (:movl :edi :eax)	; safe EAX
 		     (:cld)
 		     ;; Now we must zero-truncate the result bignum in EBX.
-		     (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :ecx)
 		    zero-truncate-loop
-		     (:cmpl 0 (:ebx (:ecx 1)
-				    ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+		     (:cmpl 0 (:ebx :ecx (:offset movitz-bignum bigit0 -4)))
 		     (:jne 'zero-truncate-done)
 		     (:subl 4 :ecx)
 		     (:jnz 'zero-truncate-loop)
@@ -1946,16 +1915,16 @@
 		     (:cmpl 4 :ecx)	; If result size is 1, the result might have..
 		     (:jne 'complete-bignum-allocation) ; ..collapsed to a fixnum.
 		     (:cmpl ,movitz:+movitz-most-positive-fixnum+
-			    (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+			    (:ebx (:offset movitz-bignum bigit0)))
 		     (:ja 'complete-bignum-allocation)
-		     (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+		     (:movl (:ebx (:offset movitz-bignum bigit0))
 			    :ecx)
 		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		     (:jmp 'return-fixnum)
 		    complete-bignum-allocation
-		     (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+		     (:movw :cx (:ebx (:offset movitz-bignum length)))
 		     (:movl :ebx :eax)
-		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
+		     (:leal (:ecx ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
 		     (:call-local-pf cons-commit)
 		    return-fixnum




From ffjeld at common-lisp.net  Sat Jul 17 22:34:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 17 Jul 2004 15:34:39 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BlxlP-0007X6-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Started work on improving * and truncate for bignums by using
destructive bignum operators for the temporaries.

Date: Sat Jul 17 15:34:38 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.74 movitz/losp/muerte/integers.lisp:1.75
--- movitz/losp/muerte/integers.lisp:1.74	Sat Jul 17 14:36:34 2004
+++ movitz/losp/muerte/integers.lisp	Sat Jul 17 15:34:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.74 2004/07/17 21:36:34 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.75 2004/07/17 22:34:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1098,6 +1098,15 @@
 		 (if (< x y)
 		     (* y x)
 		   ;; X is the biggest factor.
+		   #-movitz-reference-code
+		   (do ((r (%bignum-set-zerof (%make-bignum (ceiling (+ (integer-length x)
+								    (integer-length y))
+								 32))))
+			(length (integer-length y))
+			(i 0 (+ i 29)))
+		       ((>= i length) (%bignum-canonicalize r))
+		     (setf r (%bignum-addf r (ash (* x (ldb (byte 29 i) y)) i))))
+		   #+movitz-reference-code
 		   (do ((r 0)
 			(length (integer-length y))
 			(i 0 (+ i 29)))
@@ -1238,27 +1247,47 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (let* ((guess-pos (- (integer-length divisor) 29))
-		    (msb (ldb (byte 29 guess-pos) divisor))) 
-	       (when (eq msb most-positive-fixnum)
-		 (decf guess-pos)
-		 (setf msb (ash msb -1)))
-	       (incf msb)
-	       (do ((q 0)
-		    (r number))
-		   ((< r divisor)
-		    (assert (and (not (minusp r)) (not (minusp q))) ()
-		      "(trunc ~S ~S) r: ~S q: ~S" number divisor r q)
-;;;		    (assert (= number (+ r (* q divisor))) ()
-;;;		      "trunc failed: q: ~S R: ~S" q r)
-		    (values q r))
-		 (let* ((guess (ash (truncate r msb) (- guess-pos))))
-		   (let ((delta (* guess divisor)))
-		     (if (= 0 guess)
-			 (setf q (1+ q)
-			       r (- r divisor))
-		       (setf q (+ q guess)
-			     r (- r delta))))))))))
+	  (t 
+	   #-movitz-reference-code
+	   (let* ((guess-pos (- (integer-length divisor) 29))
+		  (msb (ldb (byte 29 guess-pos) divisor))) 
+	     (when (eq msb most-positive-fixnum)
+	       (decf guess-pos)
+	       (setf msb (ash msb -1)))
+	     (incf msb)
+	     (do ((shift (- guess-pos))
+		  (q (%bignum-set-zerof (%make-bignum (ceiling (- (integer-length number)
+								  (integer-length divisor))
+							       32))))
+		  (r number))
+		 ((< r divisor)
+		  (values (%bignum-canonicalize q)
+			  r))
+	       (let* ((guess (ash (truncate r msb) shift)))
+		 (let ((delta (* guess divisor)))
+		   (if (= 0 delta)
+		       (setf q (%bignum-addf-fixnum q 1)
+			     r (- r divisor))
+		     (setf q (%bignum-addf q guess)
+			   r (- r delta)))))))
+	   #+movitz-reference-code
+	   (let* ((guess-pos (- (integer-length divisor) 29))
+		  (msb (ldb (byte 29 guess-pos) divisor))) 
+	     (when (eq msb most-positive-fixnum)
+	       (decf guess-pos)
+	       (setf msb (ash msb -1)))
+	     (incf msb)
+	     (do ((q 0)
+		  (r number))
+		 ((< r divisor)
+		  (values q r))
+	       (let* ((guess (ash (truncate r msb) (- guess-pos))))
+		 (let ((delta (* guess divisor)))
+		   (if (= 0 guess)
+		       (setf q (1+ q)
+			     r (- r divisor))
+		     (setf q (+ q guess)
+			   r (- r delta))))))))))
 	(((integer * -1) (integer 0 *))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)




From ffjeld at common-lisp.net  Sun Jul 18 08:45:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 01:45:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1Bm7IL-0007hQ-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Wrote %bignum-compare, %bignum< and %bignum= compiler-macros.

Date: Sun Jul 18 01:45:17 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.1 movitz/losp/muerte/arithmetic-macros.lisp:1.2
--- movitz/losp/muerte/arithmetic-macros.lisp:1.1	Sat Jul 17 05:16:03 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Sun Jul 18 01:45:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.1 2004/07/17 12:16:03 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.2 2004/07/18 08:45:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -400,3 +400,48 @@
     (expt (movitz:movitz-eval base-number env)
 	  (movitz:movitz-eval power-number env))))
     
+
+(define-compiler-macro %bignum-compare (x y)
+  "Set ZF and CF according to (:cmpl y x), disregarding sign."
+  `(with-inline-assembly (:returns :nothing :labels (eax-shortest-loop
+						     ebx-shortest-loop
+						     equal-length-loop
+						     done))
+     (:compile-two-forms (:eax :ebx) ,x ,y)
+     (:xorl :ecx :ecx)
+     (:xorl :edx :edx)
+     (:movw (:eax (:offset movitz-bignum length)) :cx)
+     (:movw (:ebx (:offset movitz-bignum length)) :dx)
+     (:cmpl :ecx :edx)
+     (:je 'equal-length-loop)
+     (:jnc 'eax-shortest-loop)
+    ebx-shortest-loop
+     (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -4)))
+     (:jne 'done)
+     (:subl 4 :ecx)
+     (:cmpl :edx :ecx)
+     (:jne 'ebx-shortest-loop)
+     (:jmp 'equal-length-loop)
+    eax-shortest-loop
+     (:cmpl 0 (:ebx :edx (:offset movitz-bignum bigit0 -4)))
+     (:cmc)				; Complement CF
+     (:jne 'done)
+     (:subl 4 :edx)
+     (:cmpl :edx :ecx)
+     (:jne 'eax-shortest-loop)
+    equal-length-loop			; Compare from EDX down
+     (:subl 4 :edx)
+     (:movl (:eax :edx (:offset movitz-bignum bigit0)) :ecx)
+     (:cmpl (:ebx :edx (:offset movitz-bignum bigit0)) :ecx)
+     (:jne 'done)
+     (:testl :edx :edx)
+     (:jnz 'equal-length-loop)
+    done))
+
+(define-compiler-macro %bignum< (x y)
+  `(with-inline-assembly (:returns :boolean-below)
+     (:compile-form (:result-mode :ignore) (%bignum-compare ,x ,y))))
+
+(define-compiler-macro %bignum= (x y)
+  `(with-inline-assembly (:returns :boolean-zf=1)
+     (:compile-form (:result-mode :ignore) (%bignum-compare ,x ,y))))




From ffjeld at common-lisp.net  Sun Jul 18 08:45:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 01:45:40 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1Bm7Ii-0000mX-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Wrote %bignum-subf.

Date: Sun Jul 18 01:45:39 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.1 movitz/losp/muerte/bignums.lisp:1.2
--- movitz/losp/muerte/bignums.lisp:1.1	Sat Jul 17 12:30:09 2004
+++ movitz/losp/muerte/bignums.lisp	Sun Jul 18 01:45:39 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.1 2004/07/17 19:30:09 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.2 2004/07/18 08:45:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,7 +64,7 @@
 
 (defun copy-bignum (old)
   (check-type old bignum)
-  (let* ((length (%bignum-bigits old))
+  (let* ((length (ceiling (integer-length old) 32))
 	 (new (malloc-non-pointer-words (1+ length))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
@@ -172,3 +172,55 @@
 	      add-bignum-done)))
        (do-it)))))
 
+(defun %bignum-subf (bignum delta)
+  "Destructively subtract (abs delta) from bignum."
+  (check-type bignum bignum)
+  (etypecase delta
+    (positive-fixnum
+     (%bignum-addf-fixnum bignum (- delta)))
+    (negative-fixnum
+     (%bignum-addf-fixnum bignum delta))
+    (bignum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	      not-size1
+	       (:load-lexical (:lexical-binding bignum) :eax) ; EAX = bignum
+	       (:load-lexical (:lexical-binding delta) :ebx) ;  EBX = delta
+	       (:xorl :edx :edx)	; Counter
+	       (:xorl :ecx :ecx)	; Carry
+	      sub-bignum-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl (:ebx :edx (:offset movitz-bignum :bigit0))
+		      :ecx)
+	       (:jz 'carry+digit-overflowed) ; If CF=1, then ECX=0.
+	       (:subl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
+	      carry+digit-overflowed
+	       (:sbbl :ecx :ecx)
+	       (:negl :ecx)		; ECX = Add's Carry.
+	       (:addl 4 :edx)
+	       (:cmpw :dx (:ebx (:offset movitz-bignum length)))
+	       (:ja 'sub-bignum-loop)
+	       ;; Now, if there's a carry we must propagate it.
+	       (:jecxz 'sub-bignum-done)
+	      carry-propagate-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl 4 :edx)
+	       (:subl 1 (:eax :edx (:offset movitz-bignum bigit0 -4)))
+	       (:jc 'carry-propagate-loop)
+      sub-bignum-done)))
+       (do-it)))))
+
+(defun %bignum-set-zerof (bignum)
+  (check-type bignum bignum)
+  (dotimes (i (logior 1 (%bignum-bigits bignum)))
+    (setf (memref bignum -2 i :lisp) 0))
+  bignum)
+
+(defun %bignum= (x y)
+  (compiler-macro-call %bignum= x y))
+
+(defun %bignum< (x y)
+  (compiler-macro-call %bignum< x y))




From ffjeld at common-lisp.net  Sun Jul 18 23:45:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 16:45:45 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BmLLl-0003Rp-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Two minor fixes for some edge cases wrt. register allocation.

Date: Sun Jul 18 16:45:45 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.76 movitz/compiler.lisp:1.77
--- movitz/compiler.lisp:1.76	Thu Jul 15 17:03:42 2004
+++ movitz/compiler.lisp	Sun Jul 18 16:45:45 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.76 2004/07/16 00:03:42 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.77 2004/07/18 23:45:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1331,6 +1331,7 @@
 		      (second (second i))))))
 	 (negate-branch (branch-type)
 	   (ecase branch-type
+	     (:jb :jnb) (:jnb :jb)
 	     (:jbe :ja) (:ja :jbe)
 	     (:jz :jnz) (:jnz :jz)
 	     (:je :jne) (:jne :je)
@@ -3988,6 +3989,10 @@
 			   (decf stack-setup-size)
 			   `((:pushl :ebx)
 			     (:xchgl :eax :ebx)))
+			  ((and (eq :ebx location-0)
+				(eq :edx location-1))
+			   `((:movl :ebx :edx)
+			     (:movl :eax :ebx)))
 			  (t (append
 			      (cond
 			       ((eql 1 location-0)
@@ -6144,12 +6149,13 @@
 		(break "check that this is correct..")
 		`((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
 			 (:ebp ,(stack-frame-offset loc1)))))))
-	   (t (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A"
-		    destination loc0 loc1 type0 type1
-		    (type-specifier-singleton type0)
-		    (eq loc1 destination))
-	      (warn "ADDI: ~S" instruction)
-	      (append (cond
+	   (t
+;;;	    (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A"
+;;;		    destination loc0 loc1 type0 type1
+;;;		    (type-specifier-singleton type0)
+;;;		    (eq loc1 destination))
+;;;	     (warn "ADDI: ~S" instruction)
+	    (append (cond
 		       ((and (eq :eax loc0) (eq :ebx loc1))
 			nil)
 		       ((and (eq :ebx loc0) (eq :eax loc1))




From ffjeld at common-lisp.net  Sun Jul 18 23:48:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 16:48:22 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1BmLOI-000168-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Misc reformatting and new messages, such as overflow for exception 4.

Date: Sun Jul 18 16:48:22 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.14 movitz/losp/muerte/interrupt.lisp:1.15
--- movitz/losp/muerte/interrupt.lisp:1.14	Mon Jun  7 15:13:12 2004
+++ movitz/losp/muerte/interrupt.lisp	Sun Jul 18 16:48:22 2004
@@ -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.14 2004/06/07 22:13:12 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.15 2004/07/18 23:48:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -268,6 +268,7 @@
 	(case number
 	  (0 (error 'division-by-zero))
 	  (3 (break "Break instruction at ~@Z." $eip))
+	  (4 (error "Primitive overflow assertion failed."))
 	  (6 (error "Illegal instruction at ~@Z." $eip))
 	  (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
 		     $eip
@@ -279,17 +280,18 @@
 	     (error 'type-error :datum (@ $eax) :expected-type (@ $edx)))
 	   (format *query-io* "Enter a new value: ")
 	   (setf (@ $eax) (read *query-io*)))
-	  (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z  ECX: ~@Z EDX: ~@Z"
-		    $eip $eax $ebx $ecx $edx)
+	  (62 (error "Trying to save too many values: ~@Z." $ecx))
+	  (63 (error "Primitive assertion error. EIP=~@Z, ESI=~@Z." $eip $esi))
+	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
+		     $eip (@ (+ interrupt-frame (interrupt-frame-index :esi)))
+		     $eax $ecx))
+	  (67 (backtrace :fresh-lines nil :length 6)
 	      (dotimes (i 100000)
 		(with-inline-assembly (:returns :nothing) (:nop))))
-	  (67 (backtrace :fresh-lines nil :length 6)
+	  (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z  ECX: ~@Z EDX: ~@Z"
+		    $eip $eax $ebx $ecx $edx)
 	      (dotimes (i 100000)
 		(with-inline-assembly (:returns :nothing) (:nop))))
-	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
-		     $eip (@ (+ interrupt-frame (interrupt-frame-index :esi)))
-		     $eax $ecx))
-	  (62 (error "Trying to save too many values: ~@Z." $ecx))
 	  ((5 55)
 	   (let* ((old-bottom (prog1 (stack-bottom)
 				(setf (stack-bottom) 0)))
@@ -311,8 +313,8 @@
 		   (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X.~%"
 			   (- old-bottom new-bottom)
 			   new-bottom)
-		   (break "Stack overload exception ~D at ESP=~@Z with bottom #x~X."
-			  number
+		   (break "Stack overload exception ~D at EIP=~@Z, ESI=~@Z, ESP=~@Z, bottom=#x~X."
+			  number $eip $esi
 			  (+ interrupt-frame (interrupt-frame-index :ebp))
 			  old-bottom))
 	       (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%"




From ffjeld at common-lisp.net  Mon Jul 19 00:14:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 17:14:53 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1BmLnx-0002zz-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
More bignum compiler-macros.

Date: Sun Jul 18 17:14:53 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.2 movitz/losp/muerte/arithmetic-macros.lisp:1.3
--- movitz/losp/muerte/arithmetic-macros.lisp:1.2	Sun Jul 18 01:45:17 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Sun Jul 18 17:14:53 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.2 2004/07/18 08:45:17 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.3 2004/07/19 00:14:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,7 +25,7 @@
      (cond ,@(loop for ((x-type y-type) . then-body) in clauses
 		 collect `((and (typep x ',x-type) (typep y ',y-type))
 			   , at then-body))
-	   (t (error "Not numbers: ~S or ~S." x y)))))
+	   (t (error "Not numbers or not implemented: ~S or ~S." x y)))))
 
 
 (define-compiler-macro evenp (x)
@@ -400,7 +400,6 @@
     (expt (movitz:movitz-eval base-number env)
 	  (movitz:movitz-eval power-number env))))
     
-
 (define-compiler-macro %bignum-compare (x y)
   "Set ZF and CF according to (:cmpl y x), disregarding sign."
   `(with-inline-assembly (:returns :nothing :labels (eax-shortest-loop
@@ -445,3 +444,41 @@
 (define-compiler-macro %bignum= (x y)
   `(with-inline-assembly (:returns :boolean-zf=1)
      (:compile-form (:result-mode :ignore) (%bignum-compare ,x ,y))))
+
+(define-compiler-macro %bignum-zerop (x)
+  `(with-inline-assembly (:returns :boolean-zf=1 :labels (zerop-loop zerop-loop-end))
+     (:compile-form (:result-mode :eax) ,x)
+     (:xorl :edx :edx)
+     (:movw (:eax (:offset movitz-bignum length)) :dx)
+     (:xorl :ecx :ecx)
+    zerop-loop
+     (:cmpl :ecx (:eax :edx (:offset movitz-bignum bigit0 -4)))
+     (:jne 'zerop-loop-end)
+     (:subl 4 :edx)
+     (:jnz 'zerop-loop)
+    zerop-loop-end))
+
+(define-compiler-macro %bignum-negate (x)
+  `(with-inline-assembly (:returns :register)
+     (:compile-form (:result-mode :register) ,x)
+     (:xorl #xff00 ((:result-register) (:offset movitz-bignum type)))))
+
+(define-compiler-macro %bignum-plus-fixnum-size (x fixnum-delta)
+  "Return 1 if fixnum delta can overflow x, otherwise 0."
+  `(with-inline-assembly (:returns :eax :type (unsigned-byte 0 1)
+				   :labels (check-hi-loop check-lsb done))
+     (:compile-two-forms (:ebx :edx) ,x ,fixnum-delta)
+     (:xorl :ecx :ecx)
+     (:movw (:ebx (:offset movitz-bignum length)) :cx)
+     (:movl :ecx :eax)
+    check-hi-loop
+     (:subl 4 :ecx)
+     (:jz 'check-lsb)
+     (:cmpl -1 (:ebx :ecx (:offset movitz-bignum bigit0)))
+     (:jne 'done)
+    check-lsb
+     (:shrl ,movitz:+movitz-fixnum-shift+ :edx)
+     (:addl (:ebx (:offset movitz-bignum bigit0)) :edx)
+     (:jnc 'done)
+     (:addl ,movitz:+movitz-fixnum-factor+ :eax)
+    done))




From ffjeld at common-lisp.net  Mon Jul 19 00:54:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 17:54:25 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1BmMQD-00040G-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
More bignum work.

Date: Sun Jul 18 17:54:25 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.2 movitz/losp/muerte/bignums.lisp:1.3
--- movitz/losp/muerte/bignums.lisp:1.2	Sun Jul 18 01:45:39 2004
+++ movitz/losp/muerte/bignums.lisp	Sun Jul 18 17:54:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.2 2004/07/18 08:45:39 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.3 2004/07/19 00:54:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -24,7 +24,7 @@
 (defun %bignum-bigits (x)
   (%bignum-bigits x))
 
-(defun %bignum-canonicalize (x)
+(defun bignum-canonicalize (x)
   "Assuming x is a bignum, return the canonical integer value. That is,
 either return a fixnum, or destructively modify the bignum's length so
 that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
@@ -64,7 +64,7 @@
 
 (defun copy-bignum (old)
   (check-type old bignum)
-  (let* ((length (ceiling (integer-length old) 32))
+  (let* ((length (ceiling (bignum-integer-length old) 32))
 	 (new (malloc-non-pointer-words (1+ length))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
@@ -94,7 +94,79 @@
   (terpri)
   (values))
 
-(defun %bignum-addf-fixnum (bignum delta)
+(defun bignum-add-fixnum (bignum delta)
+  "Non-destructively add an unsigned fixnum delta to an (unsigned) bignum."
+  (check-type bignum bignum)
+  (check-type delta fixnum)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax :labels (retry-not-size1
+							not-size1
+							copy-bignum-loop
+							add-bignum-loop
+							add-bignum-done
+							no-expansion
+							pfix-pbig-done))
+	    (:compile-two-forms (:eax :ebx) bignum delta)
+	    (:testl :ebx :ebx)
+	    (:jz 'pfix-pbig-done)
+	    (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
+	    (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx)
+	    (:jne 'not-size1)
+	    (:compile-form (:result-mode :ecx) delta)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:addl (:eax (:offset movitz-bignum bigit0)) :ecx)
+	    (:jc 'retry-not-size1)
+	    (:call-local-pf box-u32-ecx)
+	    (:jmp 'pfix-pbig-done)
+	   retry-not-size1
+	    (:compile-form (:result-mode :eax) bignum)
+	    (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
+	   not-size1
+	    (:declare-label-set retry-jumper (retry-not-size1))
+	    (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
+	    (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
+			       'retry-jumper)
+			     (:edi (:edi-offset atomically-status))))
+	    (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
+		   :eax)		; Number of words
+	    (:call-local-pf get-cons-pointer)
+	    (:load-lexical (:lexical-binding bignum) :ebx) ; bignum
+	    (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
+	    (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
+		   :edx)
+	    (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB
+	   copy-bignum-loop
+	    (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+	    (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx)
+	    (:movl :ecx (:eax :edx ,movitz:+other-type-offset+))
+	    (:jnz 'copy-bignum-loop)
+
+	    (:load-lexical (:lexical-binding delta) :ecx)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:xorl :ebx :ebx)
+	    (:addl :ecx (:eax (:offset movitz-bignum bigit0)))
+	    (:jnc 'add-bignum-done)
+	   add-bignum-loop
+	    (:addl 4 :ebx)
+	    (:addl 1 (:eax :ebx (:offset movitz-bignum bigit0)))
+	    (:jc 'add-bignum-loop)
+	   add-bignum-done
+	    (:movzxw (:eax (:offset movitz-bignum length)) :ecx)
+	    (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) :ecx)
+	    (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -4)))
+	    (:je 'no-expansion)
+	    (:addl #x40000 (:eax ,movitz:+other-type-offset+))
+	    (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+	   no-expansion
+	    (:call-local-pf cons-commit)
+	    (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+			     (:edi (:edi-offset atomically-status))))
+		   
+	   pfix-pbig-done)))
+    (do-it)))
+
+(defun bignum-addf-fixnum (bignum delta)
   "Destructively add a fixnum delta (negative or positive) to an (unsigned) bignum."
   (check-type delta fixnum)
   (check-type bignum bignum)
@@ -131,14 +203,14 @@
 	   add-bignum-done)))
     (do-it)))
 
-(defun %bignum-addf (bignum delta)
+(defun bignum-addf (bignum delta)
   "Destructively add (abs delta) to bignum."
   (check-type bignum bignum)
   (etypecase delta
     (positive-fixnum
-     (%bignum-addf-fixnum bignum delta))
+     (bignum-addf-fixnum bignum delta))
     (negative-fixnum
-     (%bignum-addf-fixnum bignum (- delta)))
+     (bignum-addf-fixnum bignum (- delta)))
     (bignum
      (macrolet
 	 ((do-it ()
@@ -149,11 +221,11 @@
 	       (:xorl :edx :edx)	; Counter
 	       (:xorl :ecx :ecx)	; Carry
 	      add-bignum-loop
-	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
-	       (:jbe '(:sub-program (overflow) (:int 4)))
 	       (:addl (:ebx :edx (:offset movitz-bignum :bigit0))
 		      :ecx)
 	       (:jz 'carry+digit-overflowed) ; If CF=1, then ECX=0.
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
 	       (:addl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
 	      carry+digit-overflowed
 	       (:sbbl :ecx :ecx)
@@ -172,14 +244,14 @@
 	      add-bignum-done)))
        (do-it)))))
 
-(defun %bignum-subf (bignum delta)
+(defun bignum-subf (bignum delta)
   "Destructively subtract (abs delta) from bignum."
   (check-type bignum bignum)
   (etypecase delta
     (positive-fixnum
-     (%bignum-addf-fixnum bignum (- delta)))
+     (bignum-addf-fixnum bignum (- delta)))
     (negative-fixnum
-     (%bignum-addf-fixnum bignum delta))
+     (bignum-addf-fixnum bignum delta))
     (bignum
      (macrolet
 	 ((do-it ()
@@ -213,14 +285,253 @@
       sub-bignum-done)))
        (do-it)))))
 
-(defun %bignum-set-zerof (bignum)
+(defun bignum-shift-rightf (bignum count)
+  "Destructively right-shift bignum by count bits."
+  (check-type bignum bignum)
+  (check-type count positive-fixnum)
+  (multiple-value-bind (long-shift short-shift)
+      (truncate count 32)
+    (macrolet
+	((do-it ()
+	   `(with-inline-assembly (:returns :ebx)
+	      (:compile-two-forms (:edx :ebx) long-shift bignum)
+	      (:xorl :eax :eax)
+	     shift-long-loop
+	      (:cmpw :dx (:ebx (:offset movitz-bignum length)))
+	      (:jbe 'zero-msb-loop)
+	      (:movl (:ebx :edx (:offset movitz-bignum bigit0)) :ecx)
+	      (:movl :ecx (:ebx :eax (:offset movitz-bignum bigit0)))
+	      (:addl 4 :eax)
+	      (:addl 4 :edx)
+	      (:jmp 'shift-long-loop)
+	     zero-msb-loop
+	      (:cmpw :ax (:ebx (:offset movitz-bignum length)))
+	      (:jbe 'long-shift-done)
+	      (:movl 0 (:ebx :eax (:offset movitz-bignum bigit0)))
+	      (:addl 4 :eax)
+	      (:jmp 'zero-msb-loop)
+	     long-shift-done
+	      (:compile-form (:result-mode :ecx) short-shift)
+	      (:xorl :edx :edx)		; counter
+	      (:xorl :eax :eax)		; We need to use EAX for u32 storage.
+	      (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	      (:std)
+	     shift-short-loop
+	      (:addl 4 :edx)
+	      (:cmpw :dx (:ebx (:offset movitz-bignum length)))
+	      (:jbe 'end-shift-short-loop)
+	      (:movl (:ebx :edx (:offset movitz-bignum bigit0))
+		     :eax)
+	      (:shrdl :cl :eax
+		      (:ebx :edx (:offset movitz-bignum bigit0 -4)))
+	      (:jmp 'shift-short-loop)
+	     end-shift-short-loop
+	      (:movl :edx :eax)		; Safe EAX
+	      (:shrl :cl (:ebx :edx (:offset movitz-bignum bigit0 -4)))
+	      (:cld))))
+      (do-it))))
+
+(defun bignum-shift-leftf (bignum count)
+  "Destructively left-shift bignum by count bits."
+  (check-type bignum bignum)
+  (check-type count positive-fixnum)
+  (multiple-value-bind (long-shift short-shift)
+      (truncate count 32)
+    (macrolet
+	((do-it ()
+	   `(with-inline-assembly (:returns :ebx)
+	      (:compile-two-forms (:ecx :ebx) long-shift bignum)
+	      (:jecxz 'long-shift-done)
+	      (:xorl :eax :eax)
+	      (:movw (:ebx (:offset movitz-bignum length)) :ax)
+	      (:subl 4 :eax)		; destination pointer
+	      (:movl :eax :edx)
+	      ;; Overflow check
+	     overflow-check-loop
+	      (:cmpl 0 (:ebx :edx (:offset movitz-bignum bigit0)))
+	      (:jne '(:sub-program (overflow) (:int 4)))
+	      (:subl 4 :edx)
+	      (:subl 4 :ecx)
+	      (:jnz 'overflow-check-loop)
+	      ;; (:subl :ecx :edx)		; source = EDX = (- dest long-shift)
+	      (:jc '(:sub-program (overflow) (:int 4)))
+	     shift-long-loop
+	      (:movl (:ebx :edx (:offset movitz-bignum bigit0)) :ecx)
+	      (:movl :ecx (:ebx :eax (:offset movitz-bignum bigit0)))
+	      (:subl 4 :eax)
+	      (:subl 4 :edx)
+	      (:jnc 'shift-long-loop)
+	     zero-lsb-loop
+	      (:movl 0 (:ebx :eax (:offset movitz-bignum bigit0))) ; EDX=0
+	      (:subl 4 :eax)
+	      (:jnc 'zero-lsb-loop)
+	      
+	     long-shift-done
+	      (:compile-form (:result-mode :ecx) short-shift)
+	      (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	      (:jz 'done)
+	      (:xorl :edx :edx)		; counter
+	      (:movw (:ebx (:offset movitz-bignum length)) :dx)
+	      (:subl 4 :edx)
+	      (:jz 'shift-short-lsb)
+	      (:xorl :eax :eax)
+	      (:std)
+	      ;; Overflow check
+	      (:movl (:ebx :edx (:offset movitz-bignum bigit0))
+		     :eax)
+	      (:xorl :esi :esi)
+	      (:shldl :cl :eax :esi)
+	      (jnz 'overflow)
+	     shift-short-loop
+	      (:movl (:ebx :edx (:offset movitz-bignum bigit0 -4))
+		     :eax)
+	      (:shldl :cl :eax (:ebx :edx (:offset movitz-bignum bigit0)))
+	      (:subl 4 :edx)
+	      (:jnz 'shift-short-loop)
+	      (:movl (:ebp -4) :esi)
+	      (:movl :edi :eax)		; Safe EAX
+	      (:cld)
+	     shift-short-lsb
+	      (:shll :cl (:ebx (:offset movitz-bignum bigit0)))
+	     done
+	      )))
+      (do-it))))
+
+(defun bignum-mulf (bignum factor)
+  "Destructively multiply bignum by (abs factor)."
+  (check-type bignum bignum)
+  (etypecase factor
+    (bignum
+     (error "not yet"))
+    (negative-fixnum
+     (bignum-mulf bignum (- factor)))
+    (positive-fixnum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :ebx)
+	       (:load-lexical (:lexical-binding bignum) :ebx) ; bignum
+	       (:compile-form (:result-mode :ecx) factor)
+	       (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+	       (:locally (:movl :ecx (:edi (:edi-offset scratch0))))
+	       (:xorl :ecx :ecx)	; Counter
+	       (:xorl :edx :edx)	; Initial carry
+	       (:std)			; Make EAX, EDX, ESI non-GC-roots.
+	      multiply-loop
+	       (:movl (:ebx :ecx (:offset movitz-bignum bigit0))
+		      :eax)
+	       (:movl :edx :esi)	; Save carry in ESI
+	       (:locally (:mull (:edi (:edi-offset scratch0)) :eax :edx)) ; EDX:EAX = scratch0*EAX
+	       (:addl :esi :eax)	; Add carry
+	       (:adcl 0 :edx)		; Compute next carry
+	       (:jc '(:sub-program (should-not-happen) (:int 63)))
+	       (:movl :eax (:ebx :ecx (:offset movitz-bignum bigit0)))
+	       (:addl 4 :ecx)
+	       (:cmpw :cx (:ebx (:offset movitz-bignum length)))
+	       (:ja 'multiply-loop)
+	       (:movl (:ebp -4) :esi)
+	       (:movl :edx :ecx)	; Carry into ECX
+	       (:movl :edi :eax)
+	       (:movl :edi :edx)
+	       (:cld)
+	       (:testl :ecx :ecx)	; Carry overflow?
+	       (:jnz '(:sub-program (overflow) (:int 4)))
+	       )))
+       (do-it)))))
+
+(defun bignum-truncatef (bignum divisor)
+  (etypecase divisor
+    (positive-fixnum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :ebx)
+	       (:compile-two-forms (:ebx :ecx) bignum divisor)
+	       (:xorl :edx :edx)	; hi-digit
+	       (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+	       (:std)
+	       (:xorl :esi :esi)
+	       (:movw (:ebx (:offset movitz-bignum length)) :si)
+	      divide-loop
+	       (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4))
+		      :eax)		; lo-digit
+	       (:divl :ecx :eax :edx)	; EDX:EAX = EDX:EAX/ECX
+	       (:movl :eax (:ebx :esi (:offset movitz-bignum bigit0 -4)))
+	       (:subl 4 :esi)
+	       (:jnz 'divide-loop)
+
+	       (:movl (:ebp -4) :esi)
+	       (:movl :edi :edx)
+	       (:movl :ebx :eax)
+	       (:cld))))
+       (do-it)))))
+
+(defun bignum-set-zerof (bignum)
   (check-type bignum bignum)
   (dotimes (i (logior 1 (%bignum-bigits bignum)))
     (setf (memref bignum -2 i :lisp) 0))
   bignum)
 
 (defun %bignum= (x y)
+  (check-type x bignum)
+  (check-type y bignum)
   (compiler-macro-call %bignum= x y))
 
 (defun %bignum< (x y)
+  (check-type x bignum)
+  (check-type y bignum)
   (compiler-macro-call %bignum< x y))
+
+(defun %bignum-zerop (x)
+  (compiler-macro-call %bignum-zerop x))
+
+(defun bignum-integer-length (x)
+  "Compute (integer-length (abs x))."
+  (check-type x bignum)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-form (:result-mode :ebx) x)
+	    (:movzxw (:ebx (:offset movitz-bignum length))
+		     :edx)
+	    (:xorl :eax :eax)
+	   bigit-scan-loop
+	    (:subl 4 :edx)
+	    (:jc 'done)
+	    (:cmpl 0 (:ebx :edx (:offset movitz-bignum bigit0)))
+	    (:jz 'bigit-scan-loop)
+	    ;; Now, EAX must be loaded with (+ (* EDX 32) bit-index 1).
+	    (:leal ((:edx 8)) :eax)	; Factor 8
+	    (:bsrl (:ebx :edx (:offset movitz-bignum bigit0))
+		   :ecx)
+	    (:leal ((:eax 4)) :eax)	; Factor 4
+	    (:leal ((:ecx 4) :eax 4) :eax)
+	   done)))
+    (do-it)))
+
+(defun bignum-logcount (x)
+  "Compute (logcount (abs x))."
+  (check-type x bignum)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-form (:result-mode :ebx) x)
+	    (:xorl :eax :eax)
+	    (:xorl :edx :edx)
+	    (:movw (:ebx (:offset movitz-bignum length)) :dx)
+	   word-loop
+	    (:movl (:ebx :edx (:offset movitz-bignum bigit0 -4)) :ecx)
+	   bit-loop
+	    (:jecxz 'end-bit-loop)
+	    (:shrl 1 :ecx)
+	    (:jnc 'bit-loop)
+	    (:addl ,movitz:+movitz-fixnum-factor+ :eax)
+	    (:jmp 'bit-loop)
+	   end-bit-loop
+	    (:subl 4 :edx)
+	    (:jnz 'word-loop))))
+    (do-it)))
+
+(defun %bignum-negate (x)
+  (compiler-macro-call %bignum-negate x))
+
+(defun %bignum-plus-fixnum-size (x fixnum-delta)
+  (compiler-macro-call %bignum-plus-fixnum-size x fixnum-delta))




From ffjeld at common-lisp.net  Mon Jul 19 00:54:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 17:54:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BmMQI-000480-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
More bignum work.

Date: Sun Jul 18 17:54:29 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.75 movitz/losp/muerte/integers.lisp:1.76
--- movitz/losp/muerte/integers.lisp:1.75	Sat Jul 17 15:34:38 2004
+++ movitz/losp/muerte/integers.lisp	Sun Jul 18 17:54:29 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.75 2004/07/17 22:34:38 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.76 2004/07/19 00:54:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -438,8 +438,10 @@
 			  (:jmp 'fix-fix-ok)))
 		  fix-fix-ok))
 		((positive-bignum positive-fixnum)
-		 (funcall '+ y x))
+		 (+ y x))
 		((positive-fixnum positive-bignum)
+		 (bignum-add-fixnum y x)
+		 #+ignore
 		 (with-inline-assembly (:returns :eax :labels (retry-not-size1
 							       not-size1
 							       copy-bignum-loop
@@ -729,14 +731,36 @@
 		(((eql 0) t)
 		 (- subtrahend))
 		((fixnum fixnum)
-		 (with-inline-assembly (:returns :eax :side-effects nil)
+		 (with-inline-assembly (:returns :eax :labels (done negative-result))
 		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
 		   (:subl :ebx :eax)
-		   (:into)))
+		   (:jno 'done)
+		   (:jnc 'negative-result)
+		   (:movl :eax :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:orl ,(- movitz:+movitz-most-negative-fixnum+) :ecx)
+		   (:call-local-pf box-u32-ecx)
+		   (:jmp 'done)
+		  negative-result
+		   (:movl :eax :ecx)
+		   (:negl :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:call-local-pf box-u32-ecx)
+		   (:xorl #xff00 (:eax (:offset movitz-bignum type)))
+		  done))
 		((positive-bignum fixnum)
 		 (+ (- subtrahend) minuend))
 		((fixnum positive-bignum)
-		 (- (+ (- minuend) subtrahend)))
+		 (%negatef (+ subtrahend (- minuend))
+			   subtrahend minuend))
+;;;		((positive-fixnum positive-bignum)
+;;;		 (%bignum-canonicalize
+;;;		  (%bignum-negate
+;;;		   (bignum-subf (copy-bignum subtrahend) minuend))))
+;;;		((negative-fixnum positive-bignum)
+;;;		 (%bignum-canonicalize
+;;;		  (%negatef (bignum-add-fixnum subtrahend minuend)
+;;;			    subtrahend minuend)))
 		((positive-bignum positive-bignum)
 		 (cond
 		  ((= minuend subtrahend)
@@ -847,7 +871,7 @@
 	  (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
 	  (:shll :cl :eax)))
        (t (check-type integer (integer 0 *))
-	  (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
+	  (let ((result (%make-bignum (ceiling result-length 32))))
 	    (dotimes (i (* 2 (%bignum-bigits result)))
 	      (setf (memref result -2 i :unsigned-byte16)
 		(let ((pos (- (* i 16) count)))
@@ -877,7 +901,7 @@
 	       result-length)		; 1 or 0.
 	      (t (multiple-value-bind (long short)
 		     (truncate count 16)
-		   (let ((result (%make-bignum (1+ (truncate (+ result-length 31) 32)))))
+		   (let ((result (%make-bignum (1+ (ceiling result-length 32)))))
 		     (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
 		       (dotimes (i (* 2 (%bignum-bigits result)))
 			 (let ((src (+ i long)))
@@ -937,16 +961,26 @@
 	    `(with-inline-assembly (:returns :eax)
 	       (:compile-form (:result-mode :ebx) integer)
 	       (:movzxw (:ebx (:offset movitz-bignum length))
-			:ecx)
-	       (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+))
-		      :eax)		; bigits-1
-	       (:bsrl (:ebx (:ecx 1) (:offset movitz-bignum bigit0 -4))
+			:edx)
+	       (:xorl :eax :eax)
+	      bigit-scan-loop
+	       (:subl 4 :edx)
+	       (:jc 'done)
+	       (:cmpl 0 (:ebx :edx (:offset movitz-bignum bigit0)))
+	       (:jz 'bigit-scan-loop)
+	       ;; Now, EAX must be loaded with (+ (* EDX 32) bit-index 1).
+	       (:leal ((:edx 8)) :eax)	; Factor 8
+	       (:bsrl (:ebx :edx (:offset movitz-bignum bigit0))
 		      :ecx)
-	       (:shll 5 :eax)		; bits = bigits*32 + (bit-index+1)
-	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax
-							     ,movitz:+movitz-fixnum-factor+)
-		      :eax))))
-       (do-it)))))
+	       (:leal ((:eax 4)) :eax)	; Factor 4
+	       (:leal ((:ecx 4) :eax 4) :eax)
+	      done)))
+       (do-it)))
+    (negative-bignum
+     (let ((abs-length (bignum-integer-length integer)))
+       (if (= 1 (bignum-logcount integer))
+	   (1- abs-length)
+	 abs-length)))))
 
 ;;; Multiplication
 
@@ -1033,16 +1067,15 @@
 		   (with-inline-assembly (:returns :eax)
 		    retry
 		     (:declare-label-set retry-jumper (retry))
+		     (:compile-two-forms (:eax :ebx) (integer-length x) (integer-length y))
 		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
 		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 					'retry-jumper)
 				      (:edi (:edi-offset atomically-status))))
-			     
-		     (:compile-form (:result-mode :eax) y)
-		     (:movzxw (:eax (:offset movitz-bignum length))
-			      :ecx)
-		     (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
-			    :eax)
+		     ;; Compute (1+ (ceiling (+ (len x) (len y)) 32)) ..
+		     (:leal (:eax :ebx ,(* 4 (+ 31 32))) :eax)
+		     (:andl ,(logxor #xffffffff (* 31 4)) :eax)
+		     (:shrl 5 :eax)
 		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
 
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
@@ -1099,13 +1132,19 @@
 		     (* y x)
 		   ;; X is the biggest factor.
 		   #-movitz-reference-code
-		   (do ((r (%bignum-set-zerof (%make-bignum (ceiling (+ (integer-length x)
-								    (integer-length y))
-								 32))))
+		   (do ((tmp (%make-bignum (ceiling (+ (integer-length x)
+						       (integer-length y))
+						    32)))
+			(r (bignum-set-zerof (%make-bignum (ceiling (+ (integer-length x)
+								       (integer-length y))
+								    32))))
 			(length (integer-length y))
 			(i 0 (+ i 29)))
 		       ((>= i length) (%bignum-canonicalize r))
-		     (setf r (%bignum-addf r (ash (* x (ldb (byte 29 i) y)) i))))
+		     (bignum-set-zerof tmp)
+		     (bignum-addf r (bignum-shift-leftf (bignum-mulf-fixnum (bignum-addf tmp x)
+									    (ldb (byte 29 i) y))
+							i)))
 		   #+movitz-reference-code
 		   (do ((r 0)
 			(length (integer-length y))
@@ -1134,7 +1173,7 @@
    (t (number divisor)
       (number-double-dispatch (number divisor)
 	((t (eql 1))
-	 number)
+	 (values number 0))
 	((fixnum fixnum)
 	 (with-inline-assembly (:returns :multiple-values)
 	   (:compile-form (:result-mode :eax) number)
@@ -1174,31 +1213,28 @@
 		     (:popl :ebx)
 		     (:jmp 'done)
 		    not-size1
+		     (:xorl :eax :eax)
 		     (:compile-form (:result-mode :ebx) number)
-		     (:movzxw (:ebx (:offset movitz-bignum length))
-			      :ecx)
-	     
+		     (:movw (:ebx (:offset movitz-bignum length)) :ax)
 		     (:declare-label-set retry-jumper (not-size1))
 		     (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
 		     (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
 					'retry-jumper)
 				      (:edi (:edi-offset atomically-status))))
-
-		     (:leal ((:ecx 1) 4) :eax) ; Number of words
+		     (:addl 4 :eax)
 		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
-		     
 
-		     (:store-lexical (:lexical-binding r) :eax :type bignum)
+		     (:store-lexical (:lexical-binding r) :eax :type bignum) ; XXX breaks GC invariant!
 		     (:compile-form (:result-mode :ebx) number)
-		     (:movl (:ebx #.movitz:+other-type-offset+) :ecx)
-		     (:movl :ecx (:eax #.movitz:+other-type-offset+))
+		     (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
+		     (:movl :ecx (:eax ,movitz:+other-type-offset+))
 		     (:shrl 16 :ecx)
 	     
 		     (:xorl :edx :edx)	; edx=hi-digit=0
 					; eax=lo-digit=msd(number)
 		     (:std)
 		     (:compile-form (:result-mode :esi) divisor)
-		     (:shrl #.movitz:+movitz-fixnum-shift+ :esi)
+		     (:shrl ,movitz:+movitz-fixnum-shift+ :esi)
 
 		    divide-loop
 		     (:load-lexical (:lexical-binding number) :ebx)
@@ -1249,45 +1285,55 @@
 	  ((< number divisor) (values 0 number))
 	  (t 
 	   #-movitz-reference-code
-	   (let* ((guess-pos (- (integer-length divisor) 29))
+	   (let* ((divisor-length (integer-length divisor))
+		  (guess-pos (- divisor-length 29))
 		  (msb (ldb (byte 29 guess-pos) divisor))) 
 	     (when (eq msb most-positive-fixnum)
-	       (decf guess-pos)
+	       (incf guess-pos)
 	       (setf msb (ash msb -1)))
 	     (incf msb)
-	     (do ((shift (- guess-pos))
-		  (q (%bignum-set-zerof (%make-bignum (ceiling (- (integer-length number)
-								  (integer-length divisor))
-							       32))))
-		  (r number))
-		 ((< r divisor)
-		  (values (%bignum-canonicalize q)
-			  r))
-	       (let* ((guess (ash (truncate r msb) shift)))
-		 (let ((delta (* guess divisor)))
-		   (if (= 0 delta)
-		       (setf q (%bignum-addf-fixnum q 1)
-			     r (- r divisor))
-		     (setf q (%bignum-addf q guess)
-			   r (- r delta)))))))
+	     (do ((tmp (copy-bignum number))
+		  (tmp2 (copy-bignum number))
+		  (q (bignum-set-zerof (%make-bignum (ceiling (1+ (- (integer-length number)
+								     divisor-length))
+							      32))))
+		  (r (copy-bignum number)))
+		 ((%bignum< r divisor)
+		  (values (bignum-canonicalize q)
+			  (bignum-canonicalize r)))
+	       (let ((guess (bignum-shift-rightf
+			     (bignum-truncatef (bignum-addf (bignum-set-zerof tmp)
+							    r)
+					       msb)
+			     guess-pos)))
+		 (if (%bignum-zerop guess)
+		     (setf q (bignum-addf-fixnum q 1)
+			   r (bignum-subf r divisor))
+		   (setf q (bignum-addf q guess)
+			 r (do ((i 0 (+ i 29)))
+			       ((>= i divisor-length) r)
+			     (bignum-subf r (bignum-shift-leftf
+					     (bignum-mulf (bignum-addf (bignum-set-zerof tmp2) guess)
+							  (ldb (byte 29 i) divisor))
+					     i))))))))
 	   #+movitz-reference-code
 	   (let* ((guess-pos (- (integer-length divisor) 29))
 		  (msb (ldb (byte 29 guess-pos) divisor))) 
 	     (when (eq msb most-positive-fixnum)
-	       (decf guess-pos)
+	       (incf guess-pos)
 	       (setf msb (ash msb -1)))
 	     (incf msb)
-	     (do ((q 0)
+	     (do ((shift (- guess-pos))
+		  (q 0)
 		  (r number))
 		 ((< r divisor)
 		  (values q r))
-	       (let* ((guess (ash (truncate r msb) (- guess-pos))))
-		 (let ((delta (* guess divisor)))
-		   (if (= 0 guess)
-		       (setf q (1+ q)
-			     r (- r divisor))
-		     (setf q (+ q guess)
-			   r (- r delta))))))))))
+	       (let ((guess (ash (truncate r msb) shift)))
+		 (if (= 0 guess)
+		     (setf q (1+ q)
+			   r (- r divisor))
+		   (setf q (+ q guess)
+			 r (- r (* guess divisor))))))))))
 	(((integer * -1) (integer 0 *))
 	 (multiple-value-bind (q r)
 	     (truncate (- number) divisor)




From ffjeld at common-lisp.net  Mon Jul 19 00:54:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 18 Jul 2004 17:54:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BmMQM-0004GN-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
More bignum work.

Date: Sun Jul 18 17:54:34 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.26 movitz/losp/muerte/typep.lisp:1.27
--- movitz/losp/muerte/typep.lisp:1.26	Wed Jul 14 03:53:24 2004
+++ movitz/losp/muerte/typep.lisp	Sun Jul 18 17:54:34 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.26 2004/07/14 10:53:24 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.27 2004/07/19 00:54:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -69,30 +69,35 @@
 	      (:compile-form (:result-mode :eax) ,object)
 	      (:leal (:eax ,(cl:- (movitz:tag tag-name))) :ecx)
 	      (:testb 7 :cl)))
-	 (make-other-typep (tag-name)
-	   `(with-inline-assembly-case ()
-	      (do-case (:boolean-branch-on-false)
-		(:compile-form (:result-mode :eax) ,object)
-		(:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
-		(:testb 7 :cl)
-		(:branch-when :boolean-zf=0)
-		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
-		(:branch-when :boolean-zf=0))
-	      (do-case (:boolean-branch-on-true :same :labels (other-typep-failed))
-		(:compile-form (:result-mode :eax) ,object)
-		(:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
-		(:testb 7 :cl)
-		(:jnz 'other-typep-failed)
-		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
-		(:branch-when :boolean-zf=1)
-		other-typep-failed)
-	      (do-case (t :boolean-zf=1 :labels (other-typep-failed))
-		(:compile-form (:result-mode :eax) ,object)
-		(:leal (:eax ,movitz:+other-type-offset+) :ecx)
-		(:testb 7 :cl)
-		(:jnz 'other-typep-failed)
-		(:cmpb ,(movitz:tag tag-name) (:eax ,movitz:+other-type-offset+))
-	       other-typep-failed)))
+	 (make-other-typep (tag-name &optional hi-byte)
+	   (let ((cmp (if (not hi-byte)
+			  `(:cmpb ,(movitz:tag tag-name)
+				  (:eax ,movitz:+other-type-offset+))
+			`(:cmpw ,(dpb hi-byte (byte 8 8) (movitz:tag tag-name))
+				(:eax ,movitz:+other-type-offset+)))))
+	     `(with-inline-assembly-case ()
+		(do-case (:boolean-branch-on-false)
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:branch-when :boolean-zf=0)
+		  ,cmp
+		  (:branch-when :boolean-zf=0))
+		(do-case (:boolean-branch-on-true :same :labels (other-typep-failed))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(cl:- (movitz:tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:jnz 'other-typep-failed)
+		  ,cmp
+		  (:branch-when :boolean-zf=1)
+		 other-typep-failed)
+		(do-case (t :boolean-zf=1 :labels (other-typep-failed))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,movitz:+other-type-offset+) :ecx)
+		  (:testb 7 :cl)
+		  (:jnz 'other-typep-failed)
+		  ,cmp
+		 other-typep-failed))))
 	 (make-basic-vector-typep (element-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type)
 			   (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::type))))
@@ -170,6 +175,10 @@
 		    (:testb ,movitz::+movitz-fixnum-zmask+ :al)))
 		((bignum)
 		 (make-other-typep :bignum))
+		((positive-bignum)
+		 (make-other-typep :bignum 0))
+		((negative-bignum)
+		 (make-other-typep :bignum #xff))
 		((integer number rational)
 		 `(with-inline-assembly-case ()
 		    (do-case (t :boolean-zf=1 :labels (done))




From ffjeld at common-lisp.net  Mon Jul 19 09:56:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 02:56:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BmUtG-0003jp-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Tweaks for memref :unsigned-byte32

Date: Mon Jul 19 02:56:57 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.19 movitz/losp/muerte/memref.lisp:1.20
--- movitz/losp/muerte/memref.lisp:1.19	Sat Jul 17 05:16:28 2004
+++ movitz/losp/muerte/memref.lisp	Mon Jul 19 02:56:57 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.19 2004/07/17 12:16:28 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.20 2004/07/19 09:56:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -341,8 +341,7 @@
 		  (,object-var ,object)
 		  (,index-var ,index))
 	      (with-inline-assembly (:returns :untagged-fixnum-ecx)
-		(:load-lexical (:lexical-binding ,value-var) :eax)
-		(:call-global-pf unbox-u32)
+		(:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx)
 		(:compile-two-forms (:ebx :eax) ,object-var ,index-var)
 		(:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env)))))))
 	(t (let ((value-var (gensym "memref-value-"))




From ffjeld at common-lisp.net  Mon Jul 19 09:57:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 02:57:44 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1BmUu0-0006BU-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Changed the output of printer errors while *print-safely*.

Date: Mon Jul 19 02:57:44 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.11 movitz/losp/muerte/print.lisp:1.12
--- movitz/losp/muerte/print.lisp:1.11	Thu Jul  8 08:23:53 2004
+++ movitz/losp/muerte/print.lisp	Mon Jul 19 02:57:44 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.11 2004/07/08 15:23:53 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.12 2004/07/19 09:57:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -170,7 +170,8 @@
 	  (internal-write object)
 	(handler-case (internal-write object)
 	  (serious-condition (c)
-	    (format t "#<printer error for ~Z: [~A]>" object c)))))))
+	    (print-unreadable-object (c *standard-output* :type t :identity t)
+	      (format t " while printing ~Z" object))))))))
 
 (defun internal-write (object)
   (let ((stream *standard-output*))




From ffjeld at common-lisp.net  Mon Jul 19 12:50:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 05:50:21 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BmXb3-0004w4-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed a bug in ldb%byte for bignums.

Date: Mon Jul 19 05:50:20 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.76 movitz/losp/muerte/integers.lisp:1.77
--- movitz/losp/muerte/integers.lisp:1.76	Sun Jul 18 17:54:29 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 19 05:50:20 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.76 2004/07/19 00:54:29 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.77 2004/07/19 12:50:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -754,11 +754,11 @@
 		 (%negatef (+ subtrahend (- minuend))
 			   subtrahend minuend))
 ;;;		((positive-fixnum positive-bignum)
-;;;		 (%bignum-canonicalize
+;;;		 (bignum-canonicalize
 ;;;		  (%bignum-negate
 ;;;		   (bignum-subf (copy-bignum subtrahend) minuend))))
 ;;;		((negative-fixnum positive-bignum)
-;;;		 (%bignum-canonicalize
+;;;		 (bignum-canonicalize
 ;;;		  (%negatef (bignum-add-fixnum subtrahend minuend)
 ;;;			    subtrahend minuend)))
 		((positive-bignum positive-bignum)
@@ -768,7 +768,7 @@
 		  ((< minuend subtrahend)
 		   (let ((x (- subtrahend minuend)))
 		     (%negatef x subtrahend minuend)))
-		  (t (%bignum-canonicalize
+		  (t (bignum-canonicalize
 		      (with-inline-assembly (:returns :eax)
 			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
 			(:xorl :edx :edx) ; counter
@@ -883,7 +883,7 @@
 			   (- pos)))))))
 	    (assert (or (plusp (memref result -2 (+ -1 (* 2 (%bignum-bigits result))) :unsigned-byte16))
 			(plusp (memref result -2 (+ -2 (* 2 (%bignum-bigits result))) :unsigned-byte16))))
-	    (%bignum-canonicalize result))))))
+	    (bignum-canonicalize result))))))
    (t (let ((count (- count)))
 	(etypecase integer
 	  (fixnum
@@ -909,7 +909,7 @@
 			     (if (< src src-max-bigit)
 				 (memref integer -2 src :unsigned-byte16)
 			       0)))))
-		     (%bignum-canonicalize
+		     (bignum-canonicalize
 		      (macrolet
 			  ((do-it ()
 			     `(with-inline-assembly (:returns :ebx)
@@ -1140,10 +1140,10 @@
 								    32))))
 			(length (integer-length y))
 			(i 0 (+ i 29)))
-		       ((>= i length) (%bignum-canonicalize r))
+		       ((>= i length) (bignum-canonicalize r))
 		     (bignum-set-zerof tmp)
-		     (bignum-addf r (bignum-shift-leftf (bignum-mulf-fixnum (bignum-addf tmp x)
-									    (ldb (byte 29 i) y))
+		     (bignum-addf r (bignum-shift-leftf (bignum-mulf (bignum-addf tmp x)
+								     (ldb (byte 29 i) y))
 							i)))
 		   #+movitz-reference-code
 		   (do ((r 0)
@@ -1481,7 +1481,7 @@
 		((positive-bignum positive-bignum)
 		 (if (< (%bignum-bigits y) (%bignum-bigits x))
 		     (logand y x)
-		   (%bignum-canonicalize
+		   (bignum-canonicalize
 		    (with-inline-assembly (:returns :eax)
 		      (:compile-two-forms (:eax :ebx) (copy-bignum x) y)
 		      (:movzxw (:eax (:offset movitz-bignum length))
@@ -1517,14 +1517,14 @@
 	    (((eql 0) t) integer2)
 	    (((eql -1) t) 0)
 	    ((positive-fixnum positive-bignum)
-	     (%bignum-canonicalize
+	     (bignum-canonicalize
 	      (with-inline-assembly (:returns :eax)
 		(:compile-two-forms (:eax :ecx) (copy-bignum integer2) integer1)
 		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		(:notl :ecx)
 		(:andl :ecx (:eax (:offset movitz-bignum bigit0))))))
 	    ((positive-bignum positive-bignum)
-	     (%bignum-canonicalize
+	     (bignum-canonicalize
 	      (with-inline-assembly (:returns :eax)
 		(:compile-two-forms (:eax :ebx) (copy-bignum integer2) integer1)
 		(:movzxw (:eax (:offset movitz-bignum length))
@@ -1629,7 +1629,7 @@
 	   (let ((r (copy-bignum x)))
 	     (macrolet
 		 ((do-it ()
-		    `(%bignum-canonicalize
+		    `(bignum-canonicalize
 		      (with-inline-assembly (:returns :eax)
 			(:compile-two-forms (:eax :ebx) r y)
 			(:movzxw (:ebx (:offset movitz-bignum length))
@@ -1921,7 +1921,7 @@
 		     (:movl #xffffffff (:ebx :ecx (:offset movitz-bignum bigit0)))
 		     (:cmpw :cx (:eax (:offset movitz-bignum length)))
 		     (:jc '(:sub-program (result-too-big-shouldnt-happen)
-			    (:break)))
+			    (:int 4)))
 		     (:jne 'tail-tmp-ok)
 		     ;; Sizes was equal, so set tail-tmp to zero.
 		     (:movl 0 (:ebx :ecx (:offset movitz-bignum bigit0)))
@@ -1964,6 +1964,13 @@
 		     (:movzxw (:ebx (:offset movitz-bignum length))
 			      :edx)
 		     (:popl :ecx)	; (new) bytespec size
+		     (:load-lexical (:lexical-binding size) :ecx)
+		     (:shrl 5 :ecx)
+		     (:andl -4 :ecx)	; ECX = index of (conceptual) MSB
+		     (:cmpl :ecx :edx)
+		     (:jbe 'mask-done)
+		     
+		     (:load-lexical (:lexical-binding size) :ecx)
 		     (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		     (:andl 31 :ecx)
 		     (:jz 'mask-done)




From ffjeld at common-lisp.net  Mon Jul 19 13:59:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 06:59:33 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BmYg1-0003pQ-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed ldb%byte of negative fixnums.

Date: Mon Jul 19 06:59:32 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.77 movitz/losp/muerte/integers.lisp:1.78
--- movitz/losp/muerte/integers.lisp:1.77	Mon Jul 19 05:50:20 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 19 06:59:31 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.77 2004/07/19 12:50:20 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.78 2004/07/19 13:59:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1427,10 +1427,11 @@
 ;;; bytes
 
 (defun byte (size position)
+  (check-type position (integer 0 #x3ff))
   (+ (* size #x400) position))
 
 (defun byte-size (bytespec)
-  (truncate bytespec #x400))
+  (values (truncate bytespec #x400)))
 
 (defun byte-position (bytespec)
   (rem bytespec #x400))
@@ -1692,10 +1693,10 @@
 	       (:declare-label-set retry-jumper-ones-expanded-bignum (retry-ones-expanded-bignum))
 	       ;; Calculate word-size from bytespec-size.
 	       (:compile-form (:result-mode :ecx) size)
-	       (:subl ,movitz:+movitz-fixnum-factor+ :ecx) ; Subtract 1
-	       (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; Divide by 32
-	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ; Add 1 for index->size..
-		       ,(* 2 movitz:+movitz-fixnum-factor+)) ; ..and 1 for header.
+	       (:addl ,(* 31 movitz:+movitz-fixnum-factor+) :ecx) ; Add 31
+	       (:shrl 5 :ecx)		; Divide by 32
+	       (:andl ,(- movitz:+movitz-fixnum-factor+) :ecx)
+	       (:leal (:ecx ,movitz:+movitz-fixnum-factor+) ; Add 1 for header.
 		      :eax)
 	       (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
 	       (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
@@ -1703,7 +1704,7 @@
 				(:edi (:edi-offset atomically-status))))
 	       (:call-local-pf get-cons-pointer)
 	       (:shll 16 :ecx)
-	       (:addl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) ; add 1 for index->size
+	       (:orl ,(movitz:tag :bignum 0) :ecx)
 	       (:movl :ecx (:eax ,movitz:+other-type-offset+))
 	       (:shrl 16 :ecx)
 	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)




From ffjeld at common-lisp.net  Mon Jul 19 14:44:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 07:44:21 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1BmZNN-0001jh-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Minor bignum tweaks.

Date: Mon Jul 19 07:44:21 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.3 movitz/losp/muerte/bignums.lisp:1.4
--- movitz/losp/muerte/bignums.lisp:1.3	Sun Jul 18 17:54:25 2004
+++ movitz/losp/muerte/bignums.lisp	Mon Jul 19 07:44:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.3 2004/07/19 00:54:25 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.4 2004/07/19 14:44:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -466,7 +466,7 @@
 
 (defun bignum-set-zerof (bignum)
   (check-type bignum bignum)
-  (dotimes (i (logior 1 (%bignum-bigits bignum)))
+  (dotimes (i (%bignum-bigits bignum))
     (setf (memref bignum -2 i :lisp) 0))
   bignum)
 




From ffjeld at common-lisp.net  Mon Jul 19 14:44:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 19 Jul 2004 07:44:25 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BmZNR-0001mp-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Minor bignum tweaks.

Date: Mon Jul 19 07:44:25 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.19 movitz/losp/muerte/scavenge.lisp:1.20
--- movitz/losp/muerte/scavenge.lisp:1.19	Wed Jul 14 17:27:34 2004
+++ movitz/losp/muerte/scavenge.lisp	Mon Jul 19 07:44:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.19 2004/07/15 00:27:34 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.20 2004/07/19 14:44:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,8 +48,9 @@
 	       "If x is a bignum header word, return the number of bigits."
 	       `(with-inline-assembly (:returns :eax)
 		  (:compile-form (:result-mode :eax) ,x)
-		  (:andl #xfffc0000 :eax)
-		  (:shrl 16 :eax))))
+		  (:shrl 16 :eax)
+		  (:testb ,movitz:+movitz-fixnum-zmask+ :al)
+		  (:jnz '(:sub-program () (:int 107))))))
     (do ((*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
@@ -66,7 +67,7 @@
 	    "Scanned ~Z at odd address #x~X." x scan)
 	  ;; Just skip the bigits
 	  (let* ((bigits (word-bigits x))
-		 (delta (1+ (logand bigits -2))))
+		 (delta (logior bigits 1)))
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan delta)))
 	 ((scavenge-typep x :funobj)




From ffjeld at common-lisp.net  Tue Jul 20 08:53:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:53:50 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1BmqNi-00038d-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:53:50 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.3 movitz/losp/muerte/arithmetic-macros.lisp:1.4
--- movitz/losp/muerte/arithmetic-macros.lisp:1.3	Sun Jul 18 17:14:53 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Tue Jul 20 01:53:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.3 2004/07/19 00:14:53 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.4 2004/07/20 08:53:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -93,7 +93,6 @@
 	  (max (movitz:movitz-eval max env)))
       (check-type min fixnum)
       (check-type max fixnum)
-      ;; (warn "~D -- ~D" min max)
       (cond
        ((movitz:movitz-constantp x env)
 	(<= min (movitz:movitz-eval x env) max))
@@ -108,14 +107,14 @@
 	`(with-inline-assembly (:returns :boolean-cf=1)
 	   (:compile-form (:result-mode :eax) ,x)
 	   (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-	   (:jnz '(:sub-program () (:int 107)))
+	   (:jnz '(:sub-program () (:int 64)))
 	   (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)))
        (t `(do-result-mode-case ()
 	     (:booleans
 	      (with-inline-assembly (:returns :boolean-zf=0)
 		(:compile-form (:result-mode :eax) ,x)
 		(:testb ,movitz::+movitz-fixnum-zmask+ :al)
-		(:jnz '(:sub-program () (:int 107)))
+		(:jnz '(:sub-program () (:int 64)))
 		(:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax)
 		(:sbbl :ecx :ecx)
 		(:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)
@@ -123,7 +122,7 @@
 	     (t (with-inline-assembly (:returns (:boolean-ecx 1 0))
 		  (:compile-form (:result-mode :eax) ,x)
 		  (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-		  (:jnz '(:sub-program () (:int 107)))
+		  (:jnz '(:sub-program () (:int 64)))
 		  (:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax)
 		  (:sbbl :ecx :ecx)
 		  (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax)
@@ -132,22 +131,21 @@
 	 (and (<= ,min x) (<= x ,max))))))
        
 (define-compiler-macro below (&whole form x max &environment env)
-  (let ((below-not-integer (gensym "below-not-integer-")))
-    (if (movitz:movitz-constantp max env)
-	`(with-inline-assembly (:returns :boolean-cf=1)
-	   (:compile-form (:result-mode :eax) ,x)
-	   (:testb ,movitz::+movitz-fixnum-zmask+ :al)
-	   (:jnz '(:sub-program (,below-not-integer) (:int 107)))
-	   (:cmpl ,(* (movitz:movitz-eval max env)
-		      movitz::+movitz-fixnum-factor+)
-		  :eax))
+  (if (movitz:movitz-constantp max env)
       `(with-inline-assembly (:returns :boolean-cf=1)
-	 (:compile-two-forms (:eax :ebx) ,x ,max)
-	 (:movl :eax :ecx)
-	 (:orl :ebx :ecx)
-	 (:testb ,movitz::+movitz-fixnum-zmask+ :cl)
-	 (:jnz '(:sub-program (,below-not-integer) (:int 107)))
-	 (:cmpl :ebx :eax)))))
+	 (:compile-form (:result-mode :eax) ,x)
+	 (:testb ,movitz::+movitz-fixnum-zmask+ :al)
+	 (:jnz '(:sub-program () (:int 64)))
+	 (:cmpl ,(* (movitz:movitz-eval max env)
+		    movitz::+movitz-fixnum-factor+)
+		:eax))
+    `(with-inline-assembly (:returns :boolean-cf=1)
+       (:compile-two-forms (:eax :ebx) ,x ,max)
+       (:testb ,movitz::+movitz-fixnum-zmask+ :al)
+       (:jnz '(:sub-program () (:int 64)))
+       (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
+       (:jnz '(:sub-program () (:movl :ebx :eax) (:int 64)))
+       (:cmpl :ebx :eax))))
 
 (define-compiler-macro zerop (number)
   `(= 0 ,number))




From ffjeld at common-lisp.net  Tue Jul 20 08:53:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:53:56 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1BmqNo-0003LF-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:53:56 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.4 movitz/losp/muerte/bignums.lisp:1.5
--- movitz/losp/muerte/bignums.lisp:1.4	Mon Jul 19 07:44:21 2004
+++ movitz/losp/muerte/bignums.lisp	Tue Jul 20 01:53:56 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.4 2004/07/19 14:44:21 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.5 2004/07/20 08:53:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -36,7 +36,7 @@
 	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 	    (:shrl 16 :ecx)
 	    (:jz '(:sub-program (should-never-happen)
-		   (:int 107)))
+		   (:int 63)))
 	   shrink-loop
 	    (:cmpl 4 :ecx)
 	    (:je 'shrink-no-more)
@@ -54,9 +54,9 @@
 		   (:jmp 'done)))
 	   shrink-done
 	    (:testb 3 :cl)
-	    (:jnz '(:sub-program () (:int 107)))
+	    (:jnz '(:sub-program () (:int 63)))
 	    (:testw :cx :cx)
-	    (:jz '(:sub-program () (:int 107)))
+	    (:jz '(:sub-program () (:int 63)))
 	    (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
 	   done
 	    )))
@@ -64,14 +64,14 @@
 
 (defun copy-bignum (old)
   (check-type old bignum)
-  (let* ((length (ceiling (bignum-integer-length old) 32))
+  (let* ((length (%bignum-bigits old))
 	 (new (malloc-non-pointer-words (1+ length))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
       (:compile-form (:result-mode :edx) length)
      copy-bignum-loop
-      (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx)
-      (:movl :ecx (:eax :edx #.movitz:+other-type-offset+))
+      (:movl (:ebx :edx (:offset movitz-bignum type)) :ecx)
+      (:movl :ecx (:eax :edx (:offset movitz-bignum type)))
       (:subl 4 :edx)
       (:jnc 'copy-bignum-loop))))
 




From ffjeld at common-lisp.net  Tue Jul 20 08:54:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:00 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/characters.lisp 
Message-ID: <E1BmqNs-0003YZ-00@common-lisp.net>

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

Modified Files:
	characters.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:00 2004
Author: ffjeld

Index: movitz/losp/muerte/characters.lisp
diff -u movitz/losp/muerte/characters.lisp:1.3 movitz/losp/muerte/characters.lisp:1.4
--- movitz/losp/muerte/characters.lisp:1.3	Sun Apr 18 16:16:44 2004
+++ movitz/losp/muerte/characters.lisp	Tue Jul 20 01:54:00 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb  5 19:05:01 2001
 ;;;;                
-;;;; $Id: characters.lisp,v 1.3 2004/04/18 23:16:44 ffjeld Exp $
+;;;; $Id: characters.lisp,v 1.4 2004/07/20 08:54:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -33,7 +33,7 @@
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) code)
     (:testb #.movitz::+movitz-fixnum-zmask+ :al)
-    (:jnz '(:sub-program (not-fixnum) (:int 107)))
+    (:jnz '(:sub-program (not-fixnum) (:int 64)))
     (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax)
     (:movb #.(movitz::tag :character) :al)))
 




From ffjeld at common-lisp.net  Tue Jul 20 08:54:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1BmqNx-0003ov-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:05 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.8 movitz/losp/muerte/conditions.lisp:1.9
--- movitz/losp/muerte/conditions.lisp:1.8	Mon Jul 12 00:54:30 2004
+++ movitz/losp/muerte/conditions.lisp	Tue Jul 20 01:54:05 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.8 2004/07/12 07:54:30 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.9 2004/07/20 08:54:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -130,6 +130,18 @@
 		     (funobj-name (condition-function c))
 		     (funobj-lambda-list (condition-function c))
 		     (condition-argument-count c)))))
+
+(define-condition index-out-of-range (error)
+  ((index
+    :initarg :index
+    :reader condition-index)
+   (range
+    :initarg :range
+    :reader condition-range))
+  (:report (lambda (c s)
+	     (format s "Index ~D is beyond range 0-~D."
+		     (condition-index c)
+		     (condition-range c)))))
 
 (define-condition stream-error (error)
   ((stream




From ffjeld at common-lisp.net  Tue Jul 20 08:54:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1BmqO1-0004Be-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:09 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.9 movitz/losp/muerte/defstruct.lisp:1.10
--- movitz/losp/muerte/defstruct.lisp:1.9	Thu Jul 15 14:06:55 2004
+++ movitz/losp/muerte/defstruct.lisp	Tue Jul 20 01:54:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.9 2004/07/15 21:06:55 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.10 2004/07/20 08:54:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,10 +64,10 @@
 	    ;; type test passed, read slot
 	    ,@(if (= 4 movitz::+movitz-fixnum-factor+)
 		  `((:compile-form  (:result-mode :ebx) slot-number)
-		    (:movl (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
+		    (:movl (:eax :ebx (:offset movitz-struct slot0))
 			   :eax))
 		`((:compile-form  (:result-mode :untagged-fixnum-ecx) slot-number)
-		  (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
+		  (:movl (:eax (:ecx 4) (:offset movitz-struct slot0))
 			 :eax))))))
     (do-it)))
 
@@ -86,12 +86,12 @@
 	    (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx)
 	    (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx)
 	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-	    (:jnz '(:sub-program (not-fixnum) (:int 107)))
+	    (:jnz '(:sub-program (not-fixnum) (:movl :ebx :eax) (:int 64)))
 	    (:cmpl :ecx :ebx)
-	    (:jae '(:sub-program (out-of-range) (:int 61)))
-	    ;; type test passed, read slot
-	    (:compile-form (:result-mode :ecx) value)
-	    (:movl :ecx (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))))))
+	    (:jae '(:sub-program (out-of-range) (:int 65)))
+	    ;; type test passed, write slot
+	    (:compile-form (:result-mode :edx) value)
+	    (:movl :edx (:eax :ebx (:offset movitz-struct slot0))))))
     (do-it)))
 
 (defun struct-accessor-prototype (object)




From ffjeld at common-lisp.net  Tue Jul 20 08:54:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BmqO7-0004GE-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:15 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.78 movitz/losp/muerte/integers.lisp:1.79
--- movitz/losp/muerte/integers.lisp:1.78	Mon Jul 19 06:59:31 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 20 01:54:14 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.78 2004/07/19 13:59:31 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.79 2004/07/20 08:54:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,7 +48,7 @@
 	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
 	    (:jnz '(:sub-program (n1-not-bignum)
-		    (:int 107)))
+		    (:int 64)))
 	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 	    (:cmpb ,(movitz:tag :bignum) :cl)
 	    (:jne 'n1-not-bignum)
@@ -60,7 +60,8 @@
 	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
 	    (:jnz '(:sub-program (n2-not-bignum)
-		    (:int 107)))
+		    (:movl :ebx :eax)
+		    (:int 64)))
 	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 	    (:cmpb ,(movitz:tag :bignum) :cl)
 	    (:jne 'n2-not-bignum)
@@ -184,8 +185,8 @@
 	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
 	    (:jnz '(:sub-program (not-integer)
-		    (:int 107)
-		    (:jmp 'not-integer)))
+		    (:movl :ebx :eax)
+		    (:int 64)))
 	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 	    (:cmpw ,(movitz:tag :bignum 0) :cx)
 	    (:jne 'not-plusbignum)
@@ -211,8 +212,7 @@
     (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
     (:testb 7 :cl)
     (:jnz '(:sub-program (not-integer)
-	    (:int 107)
-	    (:jmp 'not-integer)))
+	    (:int 64)))
     (:movl (:eax #.movitz:+other-type-offset+) :ecx)
     (:cmpw #.(movitz:tag :bignum 0) :cx)
     (:jne 'not-plusbignum)
@@ -1351,17 +1351,27 @@
 	))))
 
 (defun / (number &rest denominators)
-  (declare (dynamic-extent denominators))
-  (cond
-   ((null denominators)
-    (make-ratio 1 number))
-   ((null (cdr denominators))
-    (multiple-value-bind (q r)
-	(truncate number (first denominators))
-      (if (= 0 r)
-	  q
-	(error "Don't know how to divide ~S by ~S." number (first denominators)))))
-   (t (/ number (reduce '* denominators)))))
+  (numargs-case
+   (1 (x)
+      (make-rational 1 x))
+   (2 (x y)
+      (multiple-value-bind (q r)
+	  (truncate x y)
+	(if (= 0 r)
+	    q
+	  (make-rational x y))))
+   (t (number &rest denominators)
+      (declare (dynamic-extent denominators))
+      (cond
+       ((null denominators)
+	(make-rational 1 number))
+       ((null (cdr denominators))
+	(multiple-value-bind (q r)
+	    (truncate number (first denominators))
+	  (if (= 0 r)
+	      q
+	    (make-rational number (first denominators)))))
+       (t (/ number (reduce '* denominators)))))))
 	       
 (defun round (number &optional (divisor 1))
   "Mathematical rounding."




From ffjeld at common-lisp.net  Tue Jul 20 08:54:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:19 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1BmqOB-0004LK-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:19 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.15 movitz/losp/muerte/interrupt.lisp:1.16
--- movitz/losp/muerte/interrupt.lisp:1.15	Sun Jul 18 16:48:22 2004
+++ movitz/losp/muerte/interrupt.lisp	Tue Jul 20 01:54:19 2004
@@ -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.15 2004/07/18 23:48:22 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.16 2004/07/20 08:54:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -282,6 +282,8 @@
 	   (setf (@ $eax) (read *query-io*)))
 	  (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 (@ $eax) :expected-type 'integer))
+	  (65 (error 'index-out-of-range :index (@ $ebx) (@ $ecx)))
 	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
 		     $eip (@ (+ interrupt-frame (interrupt-frame-index :esi)))
 		     $eax $ecx))




From ffjeld at common-lisp.net  Tue Jul 20 08:54:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BmqOG-0004Q4-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:24 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.14 movitz/losp/muerte/los-closette.lisp:1.15
--- movitz/losp/muerte/los-closette.lisp:1.14	Thu Jul 15 14:07:13 2004
+++ movitz/losp/muerte/los-closette.lisp	Tue Jul 20 01:54:24 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.14 2004/07/15 21:07:13 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.15 2004/07/20 08:54:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -983,7 +983,7 @@
 (defclass rational (real) () (:metaclass built-in-class))
 (defclass integer (rational) () (:metaclass built-in-class))
 (defclass fixnum (integer) () (:metaclass built-in-class))
-(defclass ratio (rational) () (:metaclass built-in-class))
+;; (defclass ratio (rational) () (:metaclass built-in-class))
 (defclass float (real) () (:metaclass built-in-class))
 (defclass complex (number) () (:metaclass built-in-class))
 




From ffjeld at common-lisp.net  Tue Jul 20 08:54:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:29 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BmqOL-0004SB-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:29 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.20 movitz/losp/muerte/memref.lisp:1.21
--- movitz/losp/muerte/memref.lisp:1.20	Mon Jul 19 02:56:57 2004
+++ movitz/losp/muerte/memref.lisp	Tue Jul 20 01:54:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.20 2004/07/19 09:56:57 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.21 2004/07/20 08:54:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -628,9 +628,9 @@
 	    (:shll 2 :ecx)
 	    (:addl :ebx :eax)
 	    (:into)
-	    (:testb ,(cl:mask-field (cl:byte (cl:+ 2 movitz::+movitz-fixnum-shift+) 0) -1)
+	    (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1)
 		    :al)
-	    (:jnz '(:sub-program (unaligned) (:int 63)))
+	    (:jnz '(:sub-program () (:int 63)))
 	    (:addl :ecx :eax)
 	    (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address
 	    (,prefixes :movl (:eax) :ecx)
@@ -806,7 +806,9 @@
 	   ,@(unless (= 0 start2)
 	       `((:addl ,(* start2 movitz::+movitz-fixnum-factor+) :ebx)))
 	   (:testb ,movitz::+movitz-fixnum-zmask+ :dl)
-	   (:jnz '(:sub-program (no-fixnum) (:int 107)))
+	   (:jnz '(:sub-program ()
+		   (:movl :edx :eax)
+		   (:int 64)))
 	  copy-loop
 	   (:movl (:ebx :edx) :ecx)
 	   (:movl :ecx (:eax :edx))
@@ -824,7 +826,9 @@
 	   (:testl :edx :edx)
 	   (:jz 'done)
 	   (:testb ,movitz::+movitz-fixnum-zmask+ :dl)
-	   (:jnz '(:sub-program (no-fixnum) (:int 107)))
+	   (:jnz '(:sub-program ()
+		   (:movl :edx :eax)
+		   (:int 64)))
 	  copy-loop
 	   (:movl (:ebx :edx) :ecx)
 	   (:movl :ecx (:eax :edx))




From ffjeld at common-lisp.net  Tue Jul 20 08:54:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1BmqOQ-0004Xo-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:34 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.14 movitz/losp/muerte/more-macros.lisp:1.15
--- movitz/losp/muerte/more-macros.lisp:1.14	Tue Jul 13 15:44:05 2004
+++ movitz/losp/muerte/more-macros.lisp	Tue Jul 20 01:54:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.14 2004/07/13 22:44:05 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.15 2004/07/20 08:54:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -322,12 +322,31 @@
 			      ,format-control , at format-arguments)
      , at body))
 
+(define-compiler-macro %run-time-context-slot (&whole form &environment env slot-name
+					       &optional (context '(current-run-time-context)))
+  (if (not (and (movitz:movitz-constantp slot-name env)
+		(equal context '(current-run-time-context))))
+      form
+    (let ((slot-name (movitz::eval-form slot-name env)))
+      (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz))
+	(movitz::word
+	 `(with-inline-assembly (:returns :eax)
+	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))))
+	(movitz::code-vector-word
+	 `(with-inline-assembly (:returns :eax)
+	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))
+	    (:subl ,movitz::+code-vector-word-offset+ :eax)))
+	(movitz::lu32
+	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx))))))))
+
 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 
 (defmacro define-unimplemented-macro (name)
   `(defmacro ,name (&rest args)
      (declare (ignore args))
-     (error ,(format nil "Macro ~A is not implemented yet." name))))
+     (with-simple-restart (continue "Proceed with a NIL expansion for ~S." ',name)
+       (error "Macro ~S is not implemented yet." ',name))))
 
 (define-unimplemented-macro with-open-file)
 (define-unimplemented-macro restart-case)




From ffjeld at common-lisp.net  Tue Jul 20 08:54:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:38 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BmqOU-0004o0-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:38 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.30 movitz/losp/muerte/primitive-functions.lisp:1.31
--- movitz/losp/muerte/primitive-functions.lisp:1.30	Fri Jul 16 18:54:12 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Tue Jul 20 01:54:38 2004
@@ -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.30 2004/07/17 01:54:12 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.31 2004/07/20 08:54:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -530,7 +530,7 @@
     (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
     (:testb 7 :al)
     (:jnz '(:sub-program ()
-	    (:int 107)))))
+	    (:int 63)))))
   
 (defun malloc-cons-pointer ()
   "Return current cons-pointer in 8-byte units since buffer-start."
@@ -633,10 +633,8 @@
 		   :ecx)
 	    (:ret)
 	   fail
-	    (:int 107))))
+	    (:int 64))))
     (do-it)))
-
-	    
 
 ;;;;
 




From ffjeld at common-lisp.net  Tue Jul 20 08:54:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1BmqOZ-0004zA-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:43 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.12 movitz/losp/muerte/print.lisp:1.13
--- movitz/losp/muerte/print.lisp:1.12	Mon Jul 19 02:57:44 2004
+++ movitz/losp/muerte/print.lisp	Tue Jul 20 01:54:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.12 2004/07/19 09:57:44 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.13 2004/07/20 08:54:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -312,6 +312,10 @@
 			   (hash-table-count (package-object-external-symbols object))
 			   (hash-table-count (package-object-internal-symbols object))))
 	       (print-unreadable-object (object stream :identity t :type t))))
+	    (ratio
+	     (write-integer (ratio-numerator object) stream *print-base* *print-radix*)
+	     (write-char #\/ stream)
+	     (write-integer (ratio-denominator object) stream *print-base* nil))
 	    (t (if (not *never-use-print-object*)
 		   (print-object object stream)
 		 (print-unreadable-object (object stream :identity t)




From ffjeld at common-lisp.net  Tue Jul 20 08:54:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1BmqOe-00050m-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:48 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.9 movitz/losp/muerte/run-time-context.lisp:1.10
--- movitz/losp/muerte/run-time-context.lisp:1.9	Thu Jul 15 14:07:27 2004
+++ movitz/losp/muerte/run-time-context.lisp	Tue Jul 20 01:54:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.9 2004/07/15 21:07:27 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.10 2004/07/20 08:54:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,24 +30,6 @@
   (or (assoc slot-name (slot-value (class-of context) 'slot-map))
       (when errorp
 	(error "No run-time-context slot named ~S in ~S." slot-name context))))
-
-(define-compiler-macro %run-time-context-slot (&whole form &environment env slot-name
-					       &optional (context '(current-run-time-context)))
-  (if (not (and (movitz:movitz-constantp slot-name env)
-		(equal context '(current-run-time-context))))
-      form
-    (let ((slot-name (movitz::eval-form slot-name env)))
-      (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz))
-	(movitz::word
-	 `(with-inline-assembly (:returns :eax)
-	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))))
-	(movitz::code-vector-word
-	 `(with-inline-assembly (:returns :eax)
-	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))
-	    (:subl ,movitz::+code-vector-word-offset+ :eax)))
-	(movitz::lu32
-	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx))))))))
 
 (defun %run-time-context-slot (slot-name &optional (context (current-run-time-context)))
   (check-type context run-time-context)




From ffjeld at common-lisp.net  Tue Jul 20 08:54:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 01:54:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BmqOi-00053S-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Cleaned up most ":int 107" instances. Now, we mostly use the
semi-standardized ":int 64" which means that the value in EAX wasn't
integer. The default interrupt-handler understands this and signals
the appropriate error.

Date: Tue Jul 20 01:54:52 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.20 movitz/losp/muerte/scavenge.lisp:1.21
--- movitz/losp/muerte/scavenge.lisp:1.20	Mon Jul 19 07:44:25 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 20 01:54:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.20 2004/07/19 14:44:25 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.21 2004/07/20 08:54:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -50,7 +50,7 @@
 		  (:compile-form (:result-mode :eax) ,x)
 		  (:shrl 16 :eax)
 		  (:testb ,movitz:+movitz-fixnum-zmask+ :al)
-		  (:jnz '(:sub-program () (:int 107))))))
+		  (:jnz '(:sub-program () (:int 63))))))
     (do ((*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
@@ -64,7 +64,7 @@
 	  (error "Illegal word ~Z at ~S." x scan))
 	 ((scavenge-typep x :bignum)
 	  (assert (evenp scan) ()
-	    "Scanned ~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd location #x~X." x scan)
 	  ;; Just skip the bigits
 	  (let* ((bigits (word-bigits x))
 		 (delta (logior bigits 1)))
@@ -72,7 +72,7 @@
 	    (incf scan delta)))
 	 ((scavenge-typep x :funobj)
 	  (assert (evenp scan) ()
-	    "Scanned ~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd location #x~X." x scan)
 	  (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	  ;; Process code-vector pointers specially..
 	  (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
@@ -90,7 +90,7 @@
 	    (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers.
 	 ((scavenge-typep x :infant-object)
 	  (assert (evenp scan) ()
-	    "Scanned #x~Z at odd address #x~X." x scan)
+	    "Scanned #x~Z at odd location #x~X." x scan)
 	  (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location))
 	 ((or (scavenge-wide-typep x :basic-vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
@@ -99,21 +99,21 @@
 	      (scavenge-wide-typep x :basic-vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :code)))
 	  (assert (evenp scan) ()
-	    "Scanned ~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd location #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	  (assert (evenp scan) ()
-	    "Scanned ~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd location #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	 ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	  (assert (evenp scan) ()
-	    "Scanned ~Z at odd address #x~X." x scan)
+	    "Scanned ~Z at odd location #x~X." x scan)
 	  (let ((len (memref scan 0 1 :lisp)))
 	    (check-type len positive-fixnum)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))




From ffjeld at common-lisp.net  Tue Jul 20 09:08:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 02:08:38 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bmqc2-0004zA-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Detect if code declares a jumper-set multiple times, don't just
silently overwrite the old jumper-set, which caused very weird effects
when such a jumper was actually used.

Date: Tue Jul 20 02:08:38 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.77 movitz/compiler.lisp:1.78
--- movitz/compiler.lisp:1.77	Sun Jul 18 16:45:45 2004
+++ movitz/compiler.lisp	Tue Jul 20 02:08:38 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.77 2004/07/18 23:45:45 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.78 2004/07/20 09:08:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2497,6 +2497,8 @@
 			(:declare-label-set
 			 (destructuring-bind (name set)
 			     (cdr instruction)
+			   (assert (not (getf jumper-sets name)) ()
+			     "Duplicate jumper declaration for ~S." name)
 			   (setf (getf jumper-sets name) set))))
 		   do (let ((sub (instruction-sub-program instruction)))
 			(when sub (process sub))))))




From ffjeld at common-lisp.net  Tue Jul 20 09:17:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 02:17:38 -0700
Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog 
Message-ID: <E1Bmqkk-0001mS-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Tue Jul 20 02:17:38 2004
Author: ffjeld

Index: movitz/doc/ChangeLog
diff -u movitz/doc/ChangeLog:1.7 movitz/doc/ChangeLog:1.8
--- movitz/doc/ChangeLog:1.7	Tue Jul 13 06:05:23 2004
+++ movitz/doc/ChangeLog	Tue Jul 20 02:17:38 2004
@@ -1,3 +1,9 @@
+2004-07-19  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Bignums are now working to the extent that one can basically
+	expect things to work, although there still are arithmetic operators
+	without bignum support.
+
 2004-07-13  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Added the feature that after each GC cycle, the keyboard is




From ffjeld at common-lisp.net  Tue Jul 20 09:19:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 02:19:00 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bmqm4-0003Af-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Don't give the same name to two different jumper-sets... sigh.

Date: Tue Jul 20 02:19:00 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.79 movitz/losp/muerte/integers.lisp:1.80
--- movitz/losp/muerte/integers.lisp:1.79	Tue Jul 20 01:54:14 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 20 02:19:00 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.79 2004/07/20 08:54:14 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.80 2004/07/20 09:19:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -510,6 +510,7 @@
 		 (+ y x))
 		((negative-fixnum positive-bignum)
 		 (with-inline-assembly (:returns :eax :labels (retry-not-size1
+							       retry-jumper
 							       not-size1
 							       copy-bignum-loop
 							       add-bignum-loop
@@ -577,12 +578,14 @@
 		     (+ y x)
 		   ;; Assume x is smallest.
 		   (with-inline-assembly (:returns :eax :labels (retry-not-size1
+								 retry-jumper
 								 not-size1
 								 copy-bignum-loop
 								 add-bignum-loop
 								 add-bignum-done
 								 no-expansion
-								 pfix-pbig-done))
+								 pfix-pbig-done
+								 zero-padding-loop))
 		     (:compile-two-forms (:eax :ebx) y x)
 		     (:testl :ebx :ebx)
 		     (:jz 'pfix-pbig-done)




From ffjeld at common-lisp.net  Tue Jul 20 11:39:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 04:39:21 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bmsxt-0003GT-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed a bug in make-load-lexical wrt. loading a variable for :untagged-fixnum-ecx.

Date: Tue Jul 20 04:39:21 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.78 movitz/compiler.lisp:1.79
--- movitz/compiler.lisp:1.78	Tue Jul 20 02:08:38 2004
+++ movitz/compiler.lisp	Tue Jul 20 04:39:21 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.78 2004/07/20 09:08:38 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.79 2004/07/20 11:39:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3209,68 +3209,69 @@
     (warn "The variable ~S is used even if it was declared ignored."
 	  (binding-name binding)))
   (let ((protect-registers (cons :edx protect-registers)))
-    (flet ((chose-tmp-register (&optional preferred)
-	     (or tmp-register
-		 (unless (member preferred protect-registers)
-		   preferred)
-		 (first (set-difference '(:eax :ebx :edx)
-					protect-registers))
-		 (error "Unable to chose a temporary register.")))
-	   (install-for-single-value (lexb lexb-location result-mode indirect-p)
-	     (cond
-	      ((and (eq result-mode :untagged-fixnum-ecx)
-		    (integerp lexb-location))
-	       (assert (not indirect-p))
-	       `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
-			:ecx)
-		 (:sarl ,+movitz-fixnum-shift+ :ecx)))
-	      ((integerp lexb-location)
-	       (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
-				,(single-value-register result-mode)))
-		       (when indirect-p
-			 `((:movl (-1 ,(single-value-register result-mode))
-				  ,(single-value-register result-mode))))))
-	      (t (ecase (operator lexb-location)
-		   (:push
-		    (assert (member result-mode '(:eax :ebx :ecx :edx)))
-		    (assert (not indirect-p))
-		    `((:popl ,result-mode)))
-		   (:eax
-		    (assert (not indirect-p))
-		    (ecase result-mode
-		      ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
-		      ((:eax :single-value) nil)
-		      (:untagged-fixnum-ecx
-		       `((:movl :eax :ecx)
-			 (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))
-		   ((:ebx :ecx :edx)
-		    (assert (not indirect-p))
-		    (unless (eq result-mode lexb-location)
+    (labels ((chose-tmp-register (&optional preferred)
+	       (or tmp-register
+		   (unless (member preferred protect-registers)
+		     preferred)
+		   (first (set-difference '(:eax :ebx :edx)
+					  protect-registers))
+		   (error "Unable to chose a temporary register.")))
+	     (install-for-single-value (lexb lexb-location result-mode indirect-p)
+	       (cond
+		((and (eq result-mode :untagged-fixnum-ecx)
+		      (integerp lexb-location))
+		 (assert (not indirect-p))
+		 (assert (not (member :eax protect-registers)))
+		 (append (install-for-single-value lexb lexb-location :eax nil)
+			 `((,*compiler-global-segment-prefix*
+			    :call (:edi ,(global-constant-offset 'unbox-u32))))))
+		((integerp lexb-location)
+		 (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+				  ,(single-value-register result-mode)))
+			 (when indirect-p
+			   `((:movl (-1 ,(single-value-register result-mode))
+				    ,(single-value-register result-mode))))))
+		(t (ecase (operator lexb-location)
+		     (:push
+		      (assert (member result-mode '(:eax :ebx :ecx :edx)))
+		      (assert (not indirect-p))
+		      `((:popl ,result-mode)))
+		     (:eax
+		      (assert (not indirect-p))
 		      (ecase result-mode
-			((:eax :single-value) `((:movl ,lexb-location :eax)))
-			((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))
+			((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
+			((:eax :single-value) nil)
 			(:untagged-fixnum-ecx
-			 `((:movl ,lexb-location :ecx)
-			   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))))
-		   (:argument-stack
-		    (assert (<= 2 (function-argument-argnum lexb)) ()
-		      "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
-		    (cond
-		     ((eq result-mode :untagged-fixnum-ecx)
+			 `((:movl :eax :ecx)
+			   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))
+		     ((:ebx :ecx :edx)
 		      (assert (not indirect-p))
-		      `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx)
-			(:sarl ,+movitz-fixnum-shift+ :ecx)))
-		     (t (append `((:movl (:ebp ,(argument-stack-offset lexb))
-					 ,(single-value-register result-mode)))
-				(when indirect-p
-				  `((:movl (-1 ,(single-value-register result-mode))
-					   ,(single-value-register result-mode))))))))
-		   (:untagged-fixnum-ecx
-		    (ecase result-mode
-		      ((:eax :ebx :ecx :edx)
-		       `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode)))
-		      (:untagged-fixnum-ecx
-		       nil))))))))
+		      (unless (eq result-mode lexb-location)
+			(ecase result-mode
+			  ((:eax :single-value) `((:movl ,lexb-location :eax)))
+			  ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))
+			  (:untagged-fixnum-ecx
+			   `((:movl ,lexb-location :ecx)
+			     (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))))
+		     (:argument-stack
+		      (assert (<= 2 (function-argument-argnum lexb)) ()
+			"lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
+		      (cond
+		       ((eq result-mode :untagged-fixnum-ecx)
+			(assert (not indirect-p))
+			`((:movl (:ebp ,(argument-stack-offset lexb)) :ecx)
+			  (:sarl ,+movitz-fixnum-shift+ :ecx)))
+		       (t (append `((:movl (:ebp ,(argument-stack-offset lexb))
+					   ,(single-value-register result-mode)))
+				  (when indirect-p
+				    `((:movl (-1 ,(single-value-register result-mode))
+					     ,(single-value-register result-mode))))))))
+		     (:untagged-fixnum-ecx
+		      (ecase result-mode
+			((:eax :ebx :ecx :edx)
+			 `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode)))
+			(:untagged-fixnum-ecx
+			 nil))))))))
       (etypecase binding
 	(forwarding-binding
 	 (assert (not (binding-lended-p binding)) (binding)




From ffjeld at common-lisp.net  Tue Jul 20 12:37:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:37:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1Bmtrl-0007E1-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Operator %lispval-object supersedes fixnum-words.

Date: Tue Jul 20 05:37:05 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.21 movitz/losp/muerte/scavenge.lisp:1.22
--- movitz/losp/muerte/scavenge.lisp:1.21	Tue Jul 20 01:54:52 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 20 05:37:04 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.21 2004/07/20 08:54:52 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.22 2004/07/20 12:37:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -124,7 +124,7 @@
 	  (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan))
 	 ((scavenge-typep x :old-vector)
 	  (error "Scanned old-vector #x~Z at address #x~X." x scan))
-	 ((eq x (fixnum-word 3))
+	 ((eq x (%lispval-object 3))
 	  (incf scan)
 	  (let ((delta (memref scan 0 0 :lisp)))
 	    (check-type delta positive-fixnum)




From ffjeld at common-lisp.net  Tue Jul 20 12:37:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:37:59 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Bmtsd-0000RN-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Added operators objects-equal (a tool for GC debugging), and
%object-lispval and %lispval-object.

Date: Tue Jul 20 05:37:59 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.25 movitz/losp/muerte/inspect.lisp:1.26
--- movitz/losp/muerte/inspect.lisp:1.25	Sat Jul 17 12:32:16 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 20 05:37:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.25 2004/07/17 19:32:16 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.26 2004/07/20 12:37:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,6 +204,84 @@
      (copy-funobj old))
     (structure-object
      (copy-structure old))))
+
+(defvar *objects-equalp-last-x*)
+(defvar *objects-equalp-last-y*)
+
+(defun objects-equalp (x y)
+  (setf *objects-equalp-last-x* x
+	*objects-equalp-last-y* y)
+  (or (eql x y)
+      (if (not (and (typep x 'pointer)
+		    (typep y 'pointer)))
+	  nil
+	(macrolet ((test (accessor &rest args)
+		     `(objects-equalp (,accessor x , at args)
+				      (,accessor y , at args))))
+	  (typecase x
+	    (bignum
+	     (= x y))
+	    (function
+	     (and (test funobj-code-vector)
+		  (test funobj-code-vector%1op)
+		  (test funobj-code-vector%2op)
+		  (test funobj-code-vector%3op)
+		  (test funobj-lambda-list)
+		  (test funobj-name)
+		  (test funobj-num-constants)
+		  (test funobj-num-jumpers)
+		  (dotimes (i (funobj-num-constants x) t)
+		    (unless (test funobj-constant-ref i)))))
+	    (vector
+	     (and (typep y 'vector)
+		  (test array-element-type)
+		  (every #'objects-equalp x y)))
+	    (cons
+	     (and (typep y 'cons)
+		  (test car)
+		  (test cdr)))
+	    (structure-object
+	     (and (typep y 'structure-object)
+		  (test structure-object-name)
+		  (test structure-object-length)
+		  (dotimes (i (structure-object-length x) t)
+		    (unless (test structure-ref i)
+		      (return nil)))))
+	    (std-instance
+	     (and (typep y 'std-instance)
+		  (test std-instance-class)
+		  (test std-instance-slots))))))))
+
+(define-compiler-macro %lispval-object (integer &environment env)
+  "Return the object that is wrapped in the 32-bit integer lispval."
+  (if (movitz:movitz-constantp integer env)
+      (let ((word (movitz:movitz-eval integer env)))
+	(check-type word (unsigned-byte 32))
+	`(with-inline-assembly (:returns :register)
+	   (:movl ,word (:result-register))))
+    `(with-inline-assembly (:returns :register)
+       (:compile-form (:result-mode :eax) ,integer)
+       (:call-global-pf unbox-u32)
+       (:movl :ecx (:result-register)))))
+
+(defun %lispval-object (integer)
+  "Return the object that is wrapped in the 32-bit integer lispval."
+  (compiler-macro-call %lispval-object integer))
+
+(define-compiler-macro %object-lispval (object &environment env)
+  "Return the integer lispval that corresponds to object.
+Obviously, this correspondence is not guaranteed to hold e.g. across GC."
+  (if (movitz:movitz-constantp object env)
+      (movitz:movitz-intern (movitz:movitz-read (movitz:movitz-eval object env)) 'word)
+    `(with-inline-assembly (:returns :eax)
+       (:compile-form (:result-mode :eax) ,object)
+       (:movl :eax :ecx)
+       (:call-local-pf box-u32-ecx))))
+
+(defun %object-lispval (object)
+  "Return the integer lispval that corresponds to object.
+Obviously, this correspondence is not guaranteed to hold e.g. across GC."
+  (compiler-macro-call %object-lispval object))
 
 (defun location-in-object-p (object location)
   "Is location inside object?"




From ffjeld at common-lisp.net  Tue Jul 20 12:38:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:38:59 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1Bmttb-0004G9-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Minor edits.

Date: Tue Jul 20 05:38:59 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.36 movitz/losp/muerte/arrays.lisp:1.37
--- movitz/losp/muerte/arrays.lisp:1.36	Thu Jul 15 14:06:42 2004
+++ movitz/losp/muerte/arrays.lisp	Tue Jul 20 05:38:59 2004
@@ -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.36 2004/07/15 21:06:42 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.37 2004/07/20 12:38:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -490,14 +490,17 @@
   `(memref ,vector 2 ,index :unsigned-byte32))
 
 (defun u32ref%unsafe (vector index)
-  (u32ref%unsafe vector index))
+  (compiler-macro-call u32ref%unsafe vector index))
 
 (define-compiler-macro (setf u32ref%unsafe) (value vector index)
-  `(setf (memref ,vector 2 ,index :unsigned-byte32) ,value))
+  (let ((var (gensym "setf-u32ref-value-")))
+    ;; Use var so as to avoid re-boxing of the u32 value.
+    `(let ((,var ,value))
+       (setf (memref ,vector 2 ,index :unsigned-byte32) ,var)
+       ,var)))
 
 (defun (setf u32ref%unsafe) (value vector index)
-  (setf (u32ref%unsafe vector index) value)
-  value)
+  (compiler-macro-call (setf u32ref%unsafe) value vector index))
 
 ;;; fast vector access
 




From ffjeld at common-lisp.net  Tue Jul 20 12:39:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:39:17 -0700
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1Bmttt-0006M4-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
More symbols.

Date: Tue Jul 20 05:39:16 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.33 movitz/packages.lisp:1.34
--- movitz/packages.lisp:1.33	Thu Jul 15 14:06:24 2004
+++ movitz/packages.lisp	Tue Jul 20 05:39:16 2004
@@ -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.33 2004/07/15 21:06:24 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.34 2004/07/20 12:39:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1243,7 +1243,9 @@
 	   runtime-context-slot
 	   movitz-accessor
 	   halt-cpu
-	   fixnum-word
+	   #:%object-lispval
+	   #:%lispval-object
+	   #:objects-equalp
 	   word-nibble
 	   &edx
 	   




From ffjeld at common-lisp.net  Tue Jul 20 12:40:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:40:07 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1Bmtuh-0000kl-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Improved compiler-macro-call so that it works on setf operators.

Date: Tue Jul 20 05:40:07 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.30 movitz/special-operators.lisp:1.31
--- movitz/special-operators.lisp:1.30	Sat Jul 17 05:17:35 2004
+++ movitz/special-operators.lisp	Tue Jul 20 05:40:07 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.30 2004/07/17 12:17:35 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.31 2004/07/20 12:40:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1057,11 +1057,14 @@
 (define-special-operator muerte::compiler-macro-call (&all all &form form &env env)
   (destructuring-bind (operator &rest arguments)
       (cdr form)
-    (assert (movitz-compiler-macro-function operator env) ()
-      "There is no compiler-macro ~S." operator)
-    (compiler-call #'compile-compiler-macro-form
-      :forward all
-      :form (cons operator arguments))))
+    (let ((name (if (not (setf-name operator))
+		    operator
+		  (movitz-env-setf-operator-name (setf-name operator)))))
+      (assert (movitz-compiler-macro-function name env) ()
+	"There is no compiler-macro ~S." name)
+      (compiler-call #'compile-compiler-macro-form
+	:forward all
+	:form (cons name arguments)))))
 
 (define-special-operator muerte::do-result-mode-case (&all all &result-mode result-mode &form form)
   (loop for (cases . then-forms) in (cddr form)




From ffjeld at common-lisp.net  Tue Jul 20 12:40:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:40:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1BmtvM-0003Wq-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv13248

Modified Files:
	debugger.lisp 
Log Message:
fixnum-word is deprecated.

Date: Tue Jul 20 05:40:48 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.16 movitz/losp/x86-pc/debugger.lisp:1.17
--- movitz/losp/x86-pc/debugger.lisp:1.16	Wed Jul 14 17:28:30 2004
+++ movitz/losp/x86-pc/debugger.lisp	Tue Jul 20 05:40:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.16 2004/07/15 00:28:30 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.17 2004/07/20 12:40:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -533,7 +533,3 @@
 	       (t (format t "~&?: ~Z" funobj))))))
   (values))
 
-(defun fixnum-word (fixnum)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) fixnum)
-    (:shrl #.movitz::+movitz-fixnum-shift+ :eax)))




From ffjeld at common-lisp.net  Tue Jul 20 12:58:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:58:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1BmuCa-00032u-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Minor edit

Date: Tue Jul 20 05:58:35 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.16 movitz/losp/muerte/functions.lisp:1.17
--- movitz/losp/muerte/functions.lisp:1.16	Thu Jul 15 14:06:59 2004
+++ movitz/losp/muerte/functions.lisp	Tue Jul 20 05:58:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.16 2004/07/15 21:06:59 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.17 2004/07/20 12:58:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -395,7 +395,7 @@
 
 (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj)))
   (let* ((num-constants (funobj-num-constants old-funobj))
-	 (funobj (malloc-pointer-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+	 (funobj (malloc-pointer-words (+ #.(movitz::movitz-type-word-size 'movitz-funobj)
 					  num-constants))))
     (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
       (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16))




From ffjeld at common-lisp.net  Tue Jul 20 12:59:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 05:59:54 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BmuDq-0006WZ-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Made primitive-function ensure-heap-cons-variable no longer preserve
EDX, because it's very difficult to preserve EDX while also observing
the GC invariant that a primitive-function cannot call another
primitive-function.

Date: Tue Jul 20 05:59:53 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.79 movitz/compiler.lisp:1.80
--- movitz/compiler.lisp:1.79	Tue Jul 20 04:39:21 2004
+++ movitz/compiler.lisp	Tue Jul 20 05:59:53 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.79 2004/07/20 11:39:21 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.80 2004/07/20 12:59:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3489,7 +3489,9 @@
 	       (append (make-load-lexical lended-binding :eax funobj t frame-map)
 		       (unless (or (typep lended-binding 'borrowed-binding)
 				   (getf (binding-lended-p lended-binding) :dynamic-extent-p))
-			 (append `((:globally (:call (:edi (:edi-offset ensure-heap-cons-variable)))))
+			 (append `((:pushl :edx)
+				   (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable))))
+				   (:popl :edx))
 				 (make-store-lexical lended-binding :eax t frame-map)))
 		       `((:movl :eax
 				(,funobj-register




From ffjeld at common-lisp.net  Tue Jul 20 13:00:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 06:00:00 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BmuDw-0006i9-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Made primitive-function ensure-heap-cons-variable no longer preserve
EDX, because it's very difficult to preserve EDX while also observing
the GC invariant that a primitive-function cannot call another
primitive-function.

Date: Tue Jul 20 06:00:00 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.31 movitz/losp/muerte/primitive-functions.lisp:1.32
--- movitz/losp/muerte/primitive-functions.lisp:1.31	Tue Jul 20 01:54:38 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Tue Jul 20 06:00:00 2004
@@ -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.31 2004/07/20 08:54:38 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.32 2004/07/20 13:00:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -571,7 +571,7 @@
     (:ret)))
 
 (define-primitive-function ensure-heap-cons-variable ()
-  "Call with lended variable (a cons) in EAX. Preserves EDX."
+  "Call with lended variable (a cons) in EAX."
   (with-inline-assembly (:returns :multiple-values)
     ;; Be defensive: Check that EAX is LISTP.
     (:leal (:eax -1) :ecx)
@@ -582,12 +582,10 @@
     (:cmpl :esp :eax)			; is cons below stack-frame?
     (:jl 'return-ok)
     ;; must migrate cell onto heap
-    (:pushl :edx)
     (:movl (:eax 3) :ebx)		; cdr
     (:movl (:eax -1) :eax)		; car
-    (:locally (:call (:edi (:edi-offset fast-cons))))
-    (:popl :edx)
-    return-ok
+    (:locally (:jmp (:edi (:edi-offset fast-cons))))
+   return-ok
     (:ret)))
 
 (define-primitive-function box-u32-ecx ()
@@ -614,7 +612,7 @@
 	    
 
 (define-primitive-function unbox-u32 ()
-  "Load (ldb (byte 32 0) EAX) into ECX."
+  "Load (ldb (byte 32 0) EAX) into ECX. Preserve EAX and EBX."
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :multiple-values)




From ffjeld at common-lisp.net  Tue Jul 20 13:13:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 06:13:41 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BmuRB-0000Rs-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Map-stack-words inspects funobjs on the stack in order to determine
the type of stack-frame etc. But the funobj might have migrated, which
is why we must apply the mapping function to funobjs before we look at them.

Date: Tue Jul 20 06:13:41 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.22 movitz/losp/muerte/scavenge.lisp:1.23
--- movitz/losp/muerte/scavenge.lisp:1.22	Tue Jul 20 05:37:04 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 20 06:13:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.22 2004/07/20 12:37:04 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.23 2004/07/20 13:13:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -142,11 +142,7 @@
   (loop for nether-frame = start-stack-frame then frame
       and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame)
       while (plusp frame)
-      do (let ((funobj (stack-frame-funobj frame t)))
-	   #+ignore
-	   (format t "~&fill ~S frame for ~S"
-		   (aref (%run-time-context-slot 'nursery-space) 0)
-		   funobj)
+      do (let ((funobj (funcall function (stack-frame-funobj frame t) nil)))
 	   (typecase funobj
 	     (function
 	      (assert (= 0 (funobj-frame-num-unboxed funobj)))
@@ -162,7 +158,7 @@
 		;; 2. Pop to interrupted frame
 		(setf nether-frame frame
 		      frame (stack-frame-uplink frame))
-		(let ((interrupted-funobj (stack-frame-funobj frame))
+		(let ((interrupted-funobj (funcall function (stack-frame-funobj frame t) nil))
 		      (interrupted-esp (+ interrupt-frame 6)))
 		  (assert (typep interrupted-funobj 'function) ()
 		    "Interrupted frame was not a normal function: ~S"




From ffjeld at common-lisp.net  Tue Jul 20 14:13:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 07:13:36 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BmvNA-000288-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
In map-stack-words, don't be so fascist about detecting an interrupted
primitive-function. That is, if we detect that the call-site calls
/some/ primitive-function, then it's ok. Previously we also checked
that the call-site matched the exact pf that was interrupted, but then
what if the pf tail-called another pf?

Date: Tue Jul 20 07:13:36 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.23 movitz/losp/muerte/scavenge.lisp:1.24
--- movitz/losp/muerte/scavenge.lisp:1.23	Tue Jul 20 06:13:41 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Jul 20 07:13:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.23 2004/07/20 13:13:41 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.24 2004/07/20 14:13:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -168,16 +168,29 @@
 					    interrupted-eip-loc)
 		      ;; The simple case: The interruptee matches interrupted EIP
 		      (map-heap-words function interrupted-esp frame)
-		    (let ((primitive-function-vector
+		    (let ((primitive-function
 			   (stack-frame-primitive-funcall interrupted-funobj
 							  interrupted-esp
 							  interrupted-eip-loc)))
-		      (if primitive-function-vector
+		      (if (not primitive-function)
+			  (error "Don't know how to scavenge across PF interrupt frame at ~S."
+				 interrupt-frame)
+			(let ((forwarded-pf (funcall function primitive-function nil)))
 			  ;; Next simplest case: The interruptee was in a primitive-function,
 			  ;; with the return-address at top of stack.
-			  (map-heap-words function (1+ interrupted-esp) frame)
-			(error "Don't know how to scavenge across interrupt frame at ~S."
-			       interrupt-frame)))))))
+			  (unless (eq primitive-function forwarded-pf)
+			    ;; The PF's vector has migrated.
+			    (let* ((interrupted-eip
+				    (interrupt-frame-ref :eip :unsigned-byte32 0 :unsigned-byte32))
+				   (offset (- interrupted-eip (%object-lispval primitive-function))))
+			      (break "Active PF moved. PF: ~Z, fwPF: ~Z, offset: ~D, PFlen ~D."
+				     primitive-function
+				     forwarded-pf
+				     offset
+				     (+ 8 (length forwarded-pf)))
+			      (setf (memref interrupted-esp 0 0 :unsigned-byte32)
+				(+ offset (%object-lispval forwarded-pf)))))
+			  (map-heap-words function (1+ interrupted-esp) frame))))))))
 	     (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))
   (values))
 
@@ -189,6 +202,7 @@
 (defun stack-frame-primitive-funcall (funobj stack-location eip-location)
   "Is stack-frame in a primitive-function?
 If so, return the primitive-function's code-vector."
+  (declare (ignore eip-location))
   (let ((return-address (memref stack-location 0 0 :unsigned-byte32))
 	(code-vector (funobj-code-vector funobj)))
     (multiple-value-bind (return-location return-delta)
@@ -219,9 +233,9 @@
 				 (:signed32
 				  ;; We must read the unsigned-byte32 that starts at ip
 				  (let ((x (logior (aref code-vector (- ip 1))
-						       (* (aref code-vector (+ 0 ip)) #x100)
-						       (* (aref code-vector (+ 1 ip)) #x10000)
-						       (* (aref code-vector (+ 2 ip)) #x1000000))))
+						   (* (aref code-vector (+ 0 ip)) #x100)
+						   (* (aref code-vector (+ 1 ip)) #x10000)
+						   (* (aref code-vector (+ 2 ip)) #x1000000))))
 				    (if (not (logbitp 7 (aref code-vector (+ ip 2))))
 					x
 				      (break "Negative 32-bit offset."))))
@@ -232,7 +246,10 @@
 							  return-delta
 							  -3 -8)))))
 		       (primitive-function (%word-offset (%run-time-context-ref offset) -2)))
-		  (check-type primitive-function code-vector)
-		  (if (not (location-in-object-p primitive-function eip-location))
+		  (if (not (typep primitive-function 'code-vector))
 		      nil
 		    primitive-function))))))))))
+;;;		  (check-type primitive-function code-vector)
+;;;		  (if (not (location-in-object-p primitive-function eip-location))
+;;;		      nil
+;;;		    primitive-function))))))))))




From ffjeld at common-lisp.net  Tue Jul 20 23:47:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:47:51 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bn4Kt-0004Om-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Various tweaks to los0-gc.

 * Bind *standard-output* to *terminal-io* during GC
 * Perform some rather extensive consistency checks before/after GC.
   This takes some time, but is probably helpful at this stage.

Date: Tue Jul 20 16:47:50 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.29 movitz/losp/los0-gc.lisp:1.30
--- movitz/losp/los0-gc.lisp:1.29	Fri Jul 16 18:56:52 2004
+++ movitz/losp/los0-gc.lisp	Tue Jul 20 16:47:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.29 2004/07/17 01:56:52 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.30 2004/07/20 23:47:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -237,6 +237,7 @@
 	    (:ret))))
     (do-it)))
 
+(defvar *gc-stack*)
 
 (defun install-los0-consing (&key (context (current-run-time-context))
 				  (kb-size 1024)
@@ -247,19 +248,20 @@
   (setf (exception-handler 113)
     (lambda (exception interrupt-frame)
       (declare (ignore exception interrupt-frame))
-      (when *gc-running*
-	(let ((muerte::*error-no-condition-for-debugger* t))
-	  (error "Recursive GC triggered.")))
-      (let ((*gc-running t))
-	(unless *gc-quiet*
-	  (format t "~&;; GC.. "))
-	(stop-and-copy)
-	(loop				; This is  a nice opportunity to poll the keyboard..
-	  (case (muerte.x86-pc.keyboard:poll-char)
-	    ((#\esc)
-	     (break "Los0 GC keyboard poll."))
-	    ((nil)
-	     (return)))))))
+      (let ((*standard-output* *terminal-io*))
+	(when *gc-running*
+	  (let ((muerte::*error-no-condition-for-debugger* t))
+	    (error "Recursive GC triggered.")))
+	(let ((*gc-running t))
+	  (unless *gc-quiet*
+	    (format t "~&;; GC.. "))
+	  (stop-and-copy)
+	  (loop				; This is  a nice opportunity to poll the keyboard..
+	    (case (muerte.x86-pc.keyboard:poll-char)
+	      ((#\esc)
+	       (break "Los0 GC keyboard poll."))
+	      ((nil)
+	       (return))))))))
   (let* ((actual-duo-space (or duo-space
 			       (allocate-duo-space (* kb-size #x100))))
 	 (last-location (object-location (cons 1 2))))
@@ -331,7 +333,8 @@
       (initialize-space oldspace)
       (values))))
 
-(defparameter *x* #500())
+
+(defparameter *x* #4000())		; Have this in static space.
 
 (defun stop-and-copy (&optional evacuator)
   (setf (fill-pointer *x*) 0)
@@ -356,7 +359,7 @@
 		   (cond
 		    ((not (object-in-space-p oldspace x))
 		     x)
-		    #+ignore ((typep x 'muerte::bignum)
+		    #+ignore ((typep x 'bignum)
 			      (let ((fwi (position (object-location x) *x* :test #'eq)))
 				(if fwi
 				    (muerte::%word-offset (aref *x* (1+ fwi)) 6)
@@ -371,10 +374,14 @@
 					   (object-tag x)))
 			       forwarded-x)
 			   (let ((forward-x (shallow-copy x)))
-			     (when (typep x 'muerte::bignum)
-			       (assert (= x forward-x)))
+			     (let ((a *x*))
+			       (when (typep x 'muerte::pointer)
+				 (vector-push (%object-lispval x) a)
+				 (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
+				 (assert (vector-push (%object-lispval forward-x) a))))
 			     (setf (memref (object-location x) 0 0 :lisp) forward-x)
 			     forward-x)))))))))
+	(setf *gc-stack* (muerte::copy-control-stack))
 	;; Scavenge roots
 	(dolist (range muerte::%memory-map-roots%)
 	  (map-heap-words evacuator (car range) (cdr range)))
@@ -389,15 +396,31 @@
 			       (+ newspace-location (space-fresh-pointer newspace)))
 	       (setf scan-pointer fresh-pointer))
 
-	#+ignore (dotimes (i (truncate (length *x*) 2))
-		   (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6))
-			 (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6)))
-		     (assert (and (object-in-space-p newspace y)
-				  (object-in-space-p oldspace x)
-				  (or (typep x 'muerte::std-instance)
-				      (equalp x y)))
-			 ()
-		       "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace)))
+	;; Consistency check..
+	(let ((a *x*))
+	  ;; First, restore the state of old-space
+	  (do ((i 0 (+ i 3)))
+	      ((>= i (length a)))
+	    (let ((old (%lispval-object (aref a i)))
+		  (old-class (aref a (+ i 1))))
+	      (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
+	  ;; Then, check that each migrated object is equalp to its new self.
+	  (do ((i 0 (+ i 3)))
+	      ((>= i (length a)))
+	    (let ((old (%lispval-object (aref a i)))
+		  (new (%lispval-object (aref a (+ i 2)))))
+	      (unless (and (object-in-space-p newspace new)
+			   (object-in-space-p oldspace old)
+			   (objects-equalp old new))
+		(let ((*old* old)
+		      (*new* new)
+		      (*old-class* (aref a (+ i 1))))
+		  (declare (special *old* *new* *old-class*))
+		  (error "GC consistency check failed:
+old object: ~Z: ~S
+new object: ~Z: ~S
+oldspace: ~Z, newspace: ~Z, i: ~D"
+			 old old new new oldspace newspace i))))))
 
 	;; GC completed, oldspace is evacuated.
 	(unless *gc-quiet*




From ffjeld at common-lisp.net  Tue Jul 20 23:50:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:50:56 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1Bn4Ns-0005gW-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:50:56 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.27 movitz/losp/muerte/basic-macros.lisp:1.28
--- movitz/losp/muerte/basic-macros.lisp:1.27	Thu Jul 15 14:06:46 2004
+++ movitz/losp/muerte/basic-macros.lisp	Tue Jul 20 16:50:56 2004
@@ -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.27 2004/07/15 21:06:46 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.28 2004/07/20 23:50:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -61,6 +61,13 @@
   `(progn
      (muerte::define-compiler-macro-compile-time ,name ,lambda-list ,body)
      ',name))
+
+(defmacro define-primitive-function (function-name lambda-list docstring &body body)
+  (declare (ignore lambda-list))
+  (assert (stringp docstring) (docstring)
+    "Mandatory docstring for define-primitive-function.")
+  `(make-primitive-function ,function-name ,docstring
+			    ,(cons 'cl:progn body)))
 
 (defmacro defpackage (package-name &rest options)
   (pushnew '(:use) options :key #'car)




From ffjeld at common-lisp.net  Tue Jul 20 23:51:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:51:01 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1Bn4Nx-00065I-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:51:01 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.10 movitz/losp/muerte/common-lisp.lisp:1.11
--- movitz/losp/muerte/common-lisp.lisp:1.10	Sat Jul 17 14:27:16 2004
+++ movitz/losp/muerte/common-lisp.lisp	Tue Jul 20 16:51:01 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.10 2004/07/17 21:27:16 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.11 2004/07/20 23:51:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,11 +18,11 @@
 (require :muerte/more-macros)
 (require :muerte/arithmetic-macros)
 (require :muerte/memref)
+(require :muerte/integers)
 (require :muerte/basic-functions)
 (require :muerte/variables)
 (require :muerte/primitive-functions)
 (require :muerte/equalp)
-(require :muerte/integers)
 (require :muerte/typep)
 (require :muerte/functions)
 (require :muerte/lists)




From ffjeld at common-lisp.net  Tue Jul 20 23:51:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:51:05 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp 
Message-ID: <E1Bn4O1-0006DB-00@common-lisp.net>

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

Modified Files:
	cpu-id.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:51:05 2004
Author: ffjeld

Index: movitz/losp/muerte/cpu-id.lisp
diff -u movitz/losp/muerte/cpu-id.lisp:1.6 movitz/losp/muerte/cpu-id.lisp:1.7
--- movitz/losp/muerte/cpu-id.lisp:1.6	Mon Jul 12 19:27:20 2004
+++ movitz/losp/muerte/cpu-id.lisp	Tue Jul 20 16:51:05 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Apr 15 22:47:13 2002
 ;;;;                
-;;;; $Id: cpu-id.lisp,v 1.6 2004/07/13 02:27:20 ffjeld Exp $
+;;;; $Id: cpu-id.lisp,v 1.7 2004/07/20 23:51:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,17 +204,6 @@
     (:cld)
     (:movl 2 :ecx)
     (:stc)))
-
-(define-compiler-macro read-time-stamp-counter ()
-  `(with-inline-assembly-case ()
-     (do-case (:register :same)
-       (:std)
-       (:rdtsc)
-       (:movl :edi :edx)
-       (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) (:result-register))
-       (:cld))
-     (do-case (t :multiple-values)
-       (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter)))))
 		      
 (defun clear-time-stamp-counter ()
   "Reset the i686 time-stamp-counter.




From ffjeld at common-lisp.net  Tue Jul 20 23:51:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:51:10 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1Bn4O6-0006KL-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:51:10 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.15 movitz/losp/muerte/los-closette.lisp:1.16
--- movitz/losp/muerte/los-closette.lisp:1.15	Tue Jul 20 01:54:24 2004
+++ movitz/losp/muerte/los-closette.lisp	Tue Jul 20 16:51:10 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.15 2004/07/20 08:54:24 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.16 2004/07/20 23:51:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -983,7 +983,7 @@
 (defclass rational (real) () (:metaclass built-in-class))
 (defclass integer (rational) () (:metaclass built-in-class))
 (defclass fixnum (integer) () (:metaclass built-in-class))
-;; (defclass ratio (rational) () (:metaclass built-in-class))
+(defclass ratio (rational) () (:metaclass built-in-class))
 (defclass float (real) () (:metaclass built-in-class))
 (defclass complex (number) () (:metaclass built-in-class))
 




From ffjeld at common-lisp.net  Tue Jul 20 23:51:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:51:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1Bn4OC-0006cL-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:51:15 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.15 movitz/losp/muerte/more-macros.lisp:1.16
--- movitz/losp/muerte/more-macros.lisp:1.15	Tue Jul 20 01:54:34 2004
+++ movitz/losp/muerte/more-macros.lisp	Tue Jul 20 16:51:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.15 2004/07/20 08:54:34 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.16 2004/07/20 23:51:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -339,6 +339,27 @@
 	(movitz::lu32
 	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx))))))))
+
+(define-compiler-macro malloc-pointer-words (words)
+  `(with-inline-assembly (:returns :eax :type pointer)
+     (:compile-form (:result-mode :eax) ,words)
+     (:call-local-pf malloc-pointer-words)))
+
+(define-compiler-macro malloc-non-pointer-words (words)
+  `(with-inline-assembly (:returns :eax :type pointer)
+     (:compile-form (:result-mode :eax) ,words)
+     (:call-local-pf malloc-non-pointer-words)))
+
+(define-compiler-macro read-time-stamp-counter ()
+  `(with-inline-assembly-case ()
+     (do-case (:register :same)
+       (:std)
+       (:rdtsc)
+       (:movl :edi :edx)
+       (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) (:result-register))
+       (:cld))
+     (do-case (t :multiple-values)
+       (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter)))))
 
 ;;; Some macros that aren't implemented, and we want to give compiler errors.
 




From ffjeld at common-lisp.net  Tue Jul 20 23:51:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:51:20 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1Bn4OG-0006y0-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Moved some macros to new files and changed the order files are
loaded/compiled. The idea is to not compile function-calls before
compiler-macros are defined, etc.

Date: Tue Jul 20 16:51:19 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.32 movitz/losp/muerte/primitive-functions.lisp:1.33
--- movitz/losp/muerte/primitive-functions.lisp:1.32	Tue Jul 20 06:00:00 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Tue Jul 20 16:51:19 2004
@@ -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.32 2004/07/20 13:00:00 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.33 2004/07/20 23:51:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,13 +19,6 @@
 
 (in-package muerte)
 
-(defmacro define-primitive-function (function-name lambda-list docstring &body body)
-  (declare (ignore lambda-list))
-  (assert (stringp docstring) (docstring)
-    "Mandatory docstring for define-primitive-function.")
-  `(make-primitive-function ,function-name ,docstring
-			    ,(cons 'cl:progn body)))
-
 (define-primitive-function trampoline-funcall%1op ()
   "Call a function with 1 argument"
   (with-inline-assembly (:returns :nothing)
@@ -470,23 +463,13 @@
     (:leal (:eax :ecx 6) :eax)
     (:ret)))
 
-(define-compiler-macro malloc-pointer-words (words)
-  `(with-inline-assembly (:returns :eax :type pointer)
-     (:compile-form (:result-mode :eax) ,words)
-     (:call-local-pf malloc-pointer-words)))
-
 (defun malloc-pointer-words (words)
   (check-type words (integer 2 *))
-  (malloc-pointer-words words))
-
-(define-compiler-macro malloc-non-pointer-words (words)
-  `(with-inline-assembly (:returns :eax :type pointer)
-     (:compile-form (:result-mode :eax) ,words)
-     (:call-local-pf malloc-non-pointer-words)))
+  (compiler-macro-call malloc-pointer-words words))
 
 (defun malloc-non-pointer-words (words)
   (check-type words (integer 2 *))
-  (malloc-non-pointer-words words))
+  (compiler-macro-call malloc-non-pointer-words words))
 
 (define-primitive-function muerte::get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.




From ffjeld at common-lisp.net  Tue Jul 20 23:53:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:53:00 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Bn4Ps-0002sY-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Wrote function copy-control-stack, which does that.

Date: Tue Jul 20 16:53:00 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.26 movitz/losp/muerte/inspect.lisp:1.27
--- movitz/losp/muerte/inspect.lisp:1.26	Tue Jul 20 05:37:59 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 20 16:53:00 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.26 2004/07/20 12:37:59 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.27 2004/07/20 23:53:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -105,8 +105,8 @@
     (<= bottom pointer top)))
 
 (defun stack-ref (pointer offset index type)
-  (assert (stack-ref-p pointer) (pointer)
-    "Stack pointer not in range: #x~X" pointer)
+  #+ignore (assert (stack-ref-p pointer) (pointer)
+	     "Stack pointer not in range: #x~X" pointer)
   (memref-int pointer offset index type))
 
 (defun current-dynamic-context ()
@@ -336,3 +336,25 @@
 	      #.(movitz::movitz-type-word-size :movitz-struct)
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
+
+(defun copy-control-stack (&optional (stack (%run-time-context-slot 'stack-vector))
+				     (frame (current-stack-frame)))
+  (assert (location-in-object-p stack frame))
+  (let* ((stack-start-location (+ 2 (object-location stack)))
+	 (frame-index (- frame stack-start-location))
+	 (copy (subseq stack frame-index))
+	 (copy-start-location (+ 2 (object-location copy)))
+	 (cc (subseq copy 0)))
+    (do ((i 0)) (nil)
+      (let ((uplink-frame (svref%unsafe copy i)))
+	(cond
+	 ((= 0 uplink-frame)
+	  (setf (svref%unsafe copy i) 0)
+	  (return (values copy cc)))
+	 (t (let ((uplink-index (- uplink-frame stack-start-location frame-index)))
+	      (assert (< -1 uplink-index (length copy)) ()
+		"Uplink-index outside copy: ~S, i: ~S" uplink-index i)
+	      (let ((x  (+ uplink-index copy-start-location)))
+		(assert (location-in-object-p copy x))
+		(setf (svref%unsafe copy i) x)
+		(setf i uplink-index)))))))))




From ffjeld at common-lisp.net  Tue Jul 20 23:53:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 20 Jul 2004 16:53:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1Bn4Qe-0006vT-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv25217

Modified Files:
	debugger.lisp 
Log Message:
Some tweaks to backtrace.

Date: Tue Jul 20 16:53:48 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.17 movitz/losp/x86-pc/debugger.lisp:1.18
--- movitz/losp/x86-pc/debugger.lisp:1.17	Tue Jul 20 05:40:48 2004
+++ movitz/losp/x86-pc/debugger.lisp	Tue Jul 20 16:53:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.17 2004/07/20 12:40:48 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.18 2004/07/20 23:53:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -431,8 +431,10 @@
     (serious-condition (conditon)
       (write-string "#<error printing frame>"))))
 
-(defun backtrace (&key ((:frame initial-stack-frame)
-			(or *debugger-invoked-stack-frame*
+(defun backtrace (&key stack
+		       ((:frame initial-stack-frame)
+			(or (and stack (svref%unsafe stack 0))
+			    *debugger-invoked-stack-frame*
 			    (current-stack-frame)))
 		       ((:spartan *backtrace-be-spartan-p*))
 		       ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*)
@@ -445,7 +447,10 @@
 	(*print-length* *backtrace-print-length*)
 	(*print-level* *backtrace-print-level*))
     (loop with conflate-count = 0 with count = 0
-	for stack-frame = initial-stack-frame then (stack-frame-uplink stack-frame)
+	for stack-frame = initial-stack-frame
+	then (let ((uplink (stack-frame-uplink stack-frame)))
+	       (assert (> uplink stack-frame))
+	       uplink)
 	as funobj = (stack-frame-funobj stack-frame t)
 	do (flet ((print-leadin (stack-frame count conflate-count)
 		    (when *backtrace-do-fresh-lines*




From lgorrie at common-lisp.net  Wed Jul 21 10:47:24 2004
From: lgorrie at common-lisp.net (Luke Gorrie)
Date: Wed, 21 Jul 2004 03:47:24 -0700
Subject: [movitz-cvs] CVS update: Directory change: movitz/ide
Message-ID: <E1BnEdA-0004HL-00@common-lisp.net>

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

Log Message:
Directory /project/movitz/cvsroot/movitz/ide added to the repository

Date: Wed Jul 21 03:47:24 2004
Author: lgorrie
New directory movitz/ide added



From lgorrie at common-lisp.net  Wed Jul 21 10:54:42 2004
From: lgorrie at common-lisp.net (Luke Gorrie)
Date: Wed, 21 Jul 2004 03:54:42 -0700
Subject: [movitz-cvs] CVS update: movitz/ide/movitz-slime.el
	movitz/ide/ide.lisp 
Message-ID: <E1BnEkE-00014m-00@common-lisp.net>

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

Added Files:
	movitz-slime.el ide.lisp 
Log Message:

Date: Wed Jul 21 03:54:42 2004
Author: lgorrie







From ffjeld at common-lisp.net  Wed Jul 21 11:45:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 04:45:53 -0700
Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt 
Message-ID: <E1BnFXl-0005UK-00@common-lisp.net>

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

Modified Files:
	bochsrc.txt 
Log Message:
Minor edits.

Date: Wed Jul 21 04:45:52 2004
Author: ffjeld

Index: movitz/bochsrc.txt
diff -u movitz/bochsrc.txt:1.4 movitz/bochsrc.txt:1.5
--- movitz/bochsrc.txt:1.4	Wed Jul 14 17:29:39 2004
+++ movitz/bochsrc.txt	Wed Jul 21 04:45:52 2004
@@ -1,6 +1,20 @@
-###############################################################
-# bochsrc.txt file for DLX Linux disk image.
-###############################################################
+######################################################################
+## 
+##    Copyright (C) 2003-2004, 
+##    Department of Computer Science, University of Tromso, Norway.
+## 
+##    For distribution policy, see the accompanying file COPYING.
+## 
+## Filename:      bochsrc.txt
+## Description:   Bochs configuration file for frodef's Movitz setup.
+##                You can use this as a template, but you'll need to
+##                change the file paths etc.
+## Author:        Frode Vatvedt Fjeld <frodef at acm.org>
+## Created at:    Wed Jul 21 13:41:59 2004
+##                
+## $Id: bochsrc.txt,v 1.5 2004/07/21 11:45:52 ffjeld Exp $
+##                
+######################################################################
 
 # how much memory the emulated machine will have
 megs: 64
@@ -11,6 +25,9 @@
 romimage: file=../../tmp/bochs-cvs/bios/BIOS-bochs-latest, address=0xf0000
 vgaromimage: ../../tmp/bochs-cvs/bios/VGABIOS-elpin-2.40
 
+# This is just to make X11 clipboard pasting into bochs work.
+keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map
+
 # what disk images will be used 
 floppya: 1_44=los0-image, status=inserted
 #floppya: 1_44=grub, status=inserted
@@ -18,8 +35,6 @@
 #diskc: file=hd10meg.img, cyl=306, heads=4, spt=17
 #newharddrivesupport: enabled=1
 
-# This is just to make X11 clipboard pasting into bochs work.
-keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map
 
 # choose the boot disk.
 boot: a




From lgorrie at common-lisp.net  Wed Jul 21 11:47:50 2004
From: lgorrie at common-lisp.net (Luke Gorrie)
Date: Wed, 21 Jul 2004 04:47:50 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BnFZe-0001QE-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed a bug where (make-array '(K)) was mistaken for multi-dimensional
(which is not supported). The dimension argument was not allowed to be
a cons even if it was really a one-element list.

Date: Wed Jul 21 04:47:49 2004
Author: lgorrie

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.37 movitz/losp/muerte/arrays.lisp:1.38
--- movitz/losp/muerte/arrays.lisp:1.37	Tue Jul 20 05:38:59 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul 21 04:47:49 2004
@@ -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.37 2004/07/20 12:38:59 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.38 2004/07/21 11:47:49 lgorrie Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -685,23 +685,25 @@
 (defun make-array (dimensions &key element-type initial-element initial-contents adjustable
 				   fill-pointer displaced-to displaced-index-offset)
   (declare (ignore adjustable displaced-to displaced-index-offset))
-  (etypecase dimensions
-    (cons
-     (error "Multi-dimensional arrays not supported."))
-    (integer
-     (cond
+  (let ((size (cond ((integerp dimensions)
+                     dimensions)
+                    ((and (consp dimensions) (null (cdr dimensions)))
+                     (car dimensions))
+                    (t
+                     (error "Multi-dimensional arrays not supported.")))))
+    (cond
       ;; These should be replaced by subtypep sometime.
       ((eq element-type 'character)
-       (make-basic-vector%character dimensions fill-pointer initial-element initial-contents))
+       (make-basic-vector%character size fill-pointer initial-element initial-contents))
       ((member element-type '(bit (unsigned-byte 1)) :test #'equal)
-       (make-basic-vector%bit dimensions fill-pointer initial-element initial-contents))
+       (make-basic-vector%bit size fill-pointer initial-element initial-contents))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (make-basic-vector%u8 dimensions fill-pointer initial-element initial-contents))
+       (make-basic-vector%u8 size fill-pointer initial-element initial-contents))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents))
+       (make-basic-vector%u32 size fill-pointer initial-element initial-contents))
       ((eq element-type 'code)
-       (make-basic-vector%code dimensions fill-pointer initial-element initial-contents))
-      (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents))))))
+       (make-basic-vector%code size fill-pointer initial-element initial-contents))
+      (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
 
 (defun vector (&rest objects)
   "=> vector"




From ffjeld at common-lisp.net  Wed Jul 21 11:48:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 04:48:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BnFa4-0002g8-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Added support for symbols in objects-equalp.

Date: Wed Jul 21 04:48:16 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.27 movitz/losp/muerte/inspect.lisp:1.28
--- movitz/losp/muerte/inspect.lisp:1.27	Tue Jul 20 16:53:00 2004
+++ movitz/losp/muerte/inspect.lisp	Wed Jul 21 04:48:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.27 2004/07/20 23:53:00 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.28 2004/07/21 11:48:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -232,6 +232,13 @@
 		  (test funobj-num-jumpers)
 		  (dotimes (i (funobj-num-constants x) t)
 		    (unless (test funobj-constant-ref i)))))
+	    (symbol
+	     (and (test memref -7 0 :lisp)
+		  (test memref -7 1 :lisp)
+		  (test memref -7 2 :lisp)
+		  (test memref -7 3 :lisp)
+		  (test memref -7 4 :lisp)
+		  (test memref -7 5 :lisp)))
 	    (vector
 	     (and (typep y 'vector)
 		  (test array-element-type)




From ffjeld at common-lisp.net  Wed Jul 21 11:49:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 04:49:48 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BnFbY-00017T-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Added docstring to objects-equalp, and removed some debugging lines.

Date: Wed Jul 21 04:49:48 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.28 movitz/losp/muerte/inspect.lisp:1.29
--- movitz/losp/muerte/inspect.lisp:1.28	Wed Jul 21 04:48:16 2004
+++ movitz/losp/muerte/inspect.lisp	Wed Jul 21 04:49:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.28 2004/07/21 11:48:16 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.29 2004/07/21 11:49:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -205,12 +205,8 @@
     (structure-object
      (copy-structure old))))
 
-(defvar *objects-equalp-last-x*)
-(defvar *objects-equalp-last-y*)
-
 (defun objects-equalp (x y)
-  (setf *objects-equalp-last-x* x
-	*objects-equalp-last-y* y)
+  "Basically, this verifies whether x is a shallow-copy of y, or vice versa."
   (or (eql x y)
       (if (not (and (typep x 'pointer)
 		    (typep y 'pointer)))




From lgorrie at common-lisp.net  Wed Jul 21 12:02:17 2004
From: lgorrie at common-lisp.net (Luke Gorrie)
Date: Wed, 21 Jul 2004 05:02:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp 
Message-ID: <E1BnFnd-000848-00@common-lisp.net>

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

Added Files:
	packet.lisp 
Log Message:
Imported packet.lisp "version 2" from small-cl-src mailing list.

Date: Wed Jul 21 05:02:15 2004
Author: lgorrie





From ffjeld at common-lisp.net  Wed Jul 21 12:19:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 05:19:15 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1BnG43-0004Be-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
When doing eval-when, execute :compile-toplevel (on the host side)
after movitz-side :execute and/or :load-toplevel. Why not?

Date: Wed Jul 21 05:19:15 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.19 movitz/special-operators-cl.lisp:1.20
--- movitz/special-operators-cl.lisp:1.19	Fri Jun 11 14:34:02 2004
+++ movitz/special-operators-cl.lisp	Wed Jul 21 05:19:15 2004
@@ -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.19 2004/06/11 21:34:02 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.20 2004/07/21 12:19:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -864,26 +864,24 @@
 (define-special-operator eval-when (&all forward &form form &top-level-p top-level-p)
   (destructuring-bind (situations &body body)
       (cdr form)
-    (when (member :compile-toplevel situations)
-;;;      (warn "EVAL-WHEN: ~S" `(progn ,@(movitz::translate-program body :muerte.cl :cl
-;;;								 :when :eval
-;;;								 :remove-double-quotes-p t)))
-      (with-compilation-unit ()
-	(dolist (toplevel-form (translate-program body :muerte.cl :cl
-						  :when :eval
-						  :remove-double-quotes-p t))
-	  (with-host-environment ()
-	    (if *compiler-compile-eval-whens*
-		(funcall (compile () `(lambda () ,toplevel-form)))
-	      (eval toplevel-form))))))
-    (if (or (member :execute situations)
-	    (and (member :load-toplevel situations)
-		 top-level-p))
-	(compiler-call #'compile-implicit-progn
-	  :defaults forward
-	  :top-level-p top-level-p
-	  :form body)
-      (compiler-values ()))))
+    (multiple-value-prog1
+	(if (or (member :execute situations)
+		(and (member :load-toplevel situations)
+		     top-level-p))
+	    (compiler-call #'compile-implicit-progn
+	      :defaults forward
+	      :top-level-p top-level-p
+	      :form body)
+	  (compiler-values ()))
+      (when (member :compile-toplevel situations)
+	(with-compilation-unit ()
+	  (dolist (toplevel-form (translate-program body :muerte.cl :cl
+						    :when :eval
+						    :remove-double-quotes-p t))
+	    (with-host-environment ()
+	      (if *compiler-compile-eval-whens*
+		  (funcall (compile () `(lambda () ,toplevel-form)))
+		(eval toplevel-form)))))))))
 
 (define-special-operator function (&funobj funobj &form form &result-mode result-mode &env env)
   (destructuring-bind (name)




From ffjeld at common-lisp.net  Wed Jul 21 12:28:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 05:28:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BnGCl-0002ur-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
In the deftype expander, have the type declaration be mirrored on the
host side.

Date: Wed Jul 21 05:28:15 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.27 movitz/losp/muerte/typep.lisp:1.28
--- movitz/losp/muerte/typep.lisp:1.27	Sun Jul 18 17:54:34 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 21 05:28:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.27 2004/07/19 00:54:34 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.28 2004/07/21 12:28:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -426,10 +426,11 @@
 	     (list 'typep x '',tname))
 	   (defun ,fname ,lambda , at body)))))
 
-(defmacro deftype (name lambda &body body)
+(defmacro deftype (&whole form name lambda &body body)
   (let ((fname (intern (format nil "~A-~A" 'deftype name))))
     `(progn
        (eval-when (:compile-toplevel)
+	 ,form
 	 (setf (gethash (translate-program ',name :cl :muerte.cl)
 			*compiler-derived-typespecs*)
 	   (lambda ,lambda , at body))




From ffjeld at common-lisp.net  Wed Jul 21 12:32:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 05:32:26 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BnGGo-0002DI-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Fixed movitz-read for structs.

Date: Wed Jul 21 05:32:26 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.47 movitz/image.lisp:1.48
--- movitz/image.lisp:1.47	Thu Jul 15 14:06:19 2004
+++ movitz/image.lisp	Wed Jul 21 05:32:26 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.47 2004/07/15 21:06:19 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.48 2004/07/21 12:32:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1460,11 +1460,12 @@
 	    (unless slot-descriptions
 	      (error "Don't know how to movitz-read struct: ~S" expr))
 	    (let ((movitz-object (make-instance 'movitz-struct
-				:name (movitz-read (type-of expr))
-				:length (length slot-descriptions))))
+				   :name (movitz-read (type-of expr))
+				   :length (length slot-descriptions))))
 	      (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
 	      (setf (slot-value movitz-object 'slot-values)
-		(mapcar #'(lambda (slot) (movitz-read (slot-value expr slot)))
+		(mapcar #'(lambda (slot)
+			    (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
 			slot-descriptions))
 	      movitz-object))))))))
 




From ffjeld at common-lisp.net  Wed Jul 21 12:33:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 05:33:55 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp 
Message-ID: <E1BnGIF-0005dQ-00@common-lisp.net>

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

Modified Files:
	packet.lisp 
Log Message:
With these modifications, the file is accepted by movitz-compile-file.

Date: Wed Jul 21 05:33:54 2004
Author: ffjeld

Index: movitz/losp/tmp/packet.lisp
diff -u movitz/losp/tmp/packet.lisp:1.1 movitz/losp/tmp/packet.lisp:1.2
--- movitz/losp/tmp/packet.lisp:1.1	Wed Jul 21 05:02:14 2004
+++ movitz/losp/tmp/packet.lisp	Wed Jul 21 05:33:54 2004
@@ -270,11 +270,11 @@
 ;;;
 ;;; The read syntax is `#e"ff:00:1:2:3:4'.
 ;;;
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute)
   (defstruct (ethernet-address (:conc-name #:ethernet-address.)
                                (:print-function print-ethernet-address))
     "48-bit Ethernet MAC address."
-    (octets (ext:required-argument) :type (array octet (6))))
+    (octets 0 :type (array octet (6))))
 
   (defun read-ethernet-address (stream &optional c n)
     "Read an ethernet address in colon-separated syntax.
@@ -397,10 +397,10 @@
 ;;;
 ;;; IP addresses also have a special read-syntax: `@10.0.0.1'.
 ;;;
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute)
   (defstruct (ipv4-address (:conc-name #:ipv4-address.)
                            (:print-function print-ipv4-address))
-    (octets (ext:required-argument) :type (array octet (4))))
+    (octets 0 :type (array octet (4))))
 
   (defun read-ipv4-address (stream &optional c n)
     "Read an IPv4 address in dotted-quad format.
@@ -826,8 +826,8 @@
            (structure-accessors name)))
 
   (defun structure-accessors (name)
-    (mapcar #'pcl::slot-definition-defstruct-accessor-symbol
-            (pcl:class-direct-slots (find-class name))))
+    #+cmu (mapcar #'pcl::slot-definition-defstruct-accessor-symbol
+		  (pcl:class-direct-slots (find-class name))))
 
   (export (structure-exports)))
 




From ffjeld at common-lisp.net  Wed Jul 21 12:49:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 05:49:24 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BnGXE-0007cJ-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Recognize "array" as the same as "simple-array".

Date: Wed Jul 21 05:49:24 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.28 movitz/losp/muerte/typep.lisp:1.29
--- movitz/losp/muerte/typep.lisp:1.28	Wed Jul 21 05:28:15 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 21 05:49:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.28 2004/07/21 12:28:15 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.29 2004/07/21 12:49:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -268,7 +268,7 @@
 		(if deriver-function
 		    `(typep ,object ',(apply deriver-function (cdr type)))
 		  (case (car type)
-		    ((simple-array)
+		    ((simple-array array)
 		     (let ((et (second type))
 			   (dim (if (listp (third type))
 				    (length (third type))
@@ -401,10 +401,6 @@
 		    (t (warn "compiling typep ~S [~A]" type
 			     (package-name (symbol-package (car type))))))))))
 	    form)))))
-
-#+ignore
-(defun foo (x)
-  (typep x '(simple-array (unsigned-byte 4))))
 
 (defmacro define-typep (tname lambda &body body)
   (let ((fname (format nil "~A-~A" 'typep tname)))




From ffjeld at common-lisp.net  Wed Jul 21 13:17:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 06:17:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <E1BnGyJ-0008NE-00@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Trying to make un-backquote run on the movitz side.

Date: Wed Jul 21 06:17:23 2004
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.5 movitz/losp/muerte/lists.lisp:1.6
--- movitz/losp/muerte/lists.lisp:1.5	Wed Jun  9 13:18:45 2004
+++ movitz/losp/muerte/lists.lisp	Wed Jul 21 06:17:22 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.5 2004/06/09 20:18:45 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.6 2004/07/21 13:17:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -451,3 +451,62 @@
     (if (member (funcall key item) list :test test)
 	list
       (cons item list))))
+
+
+(defun ub (x)
+  `(hello world))
+
+(defun un-backquote (expr level)
+  (eval (un-backquote-xxx expr level)))
+
+(defun un-backquote-xxx (form level)
+  "Dont ask.."
+  (declare (notinline un-backquote))
+  (assert (not (minusp level)))
+  (values
+   (typecase form
+     (null nil)
+     (list
+      (case (car form)
+	(backquote-comma
+	 (cadr form))
+	(t (cons 'append
+		 (loop for sub-form-head on form
+		     as sub-form = (and (consp sub-form-head)
+					(car sub-form-head))
+		     collecting
+		       (cond
+			((atom sub-form-head)
+			 (list 'quote sub-form-head))
+			((atom sub-form)
+			 (list 'quote (list sub-form)))
+			(t (case (car sub-form)
+			     (muerte::movitz-backquote
+			      (list 'list
+				    (list 'list (list 'quote 'muerte::movitz-backquote)
+					  (un-backquote-xxx (cadr sub-form) (1+ level)))))
+			     (backquote-comma
+			      (cond
+			       ((= 0 level)
+				(list 'list (cadr sub-form)))
+			       ((and (listp (cadr sub-form))
+				     (eq 'backquote-comma-at (caadr sub-form)))
+				(list 'append
+				      (list 'mapcar
+					    '(lambda (x) (list 'backquote-comma x))
+					    (cadr (cadr sub-form)))))
+			       (t (list 'list
+					(list 'list
+					      (list 'quote 'backquote-comma)
+					      (un-backquote-xxx (cadr sub-form) (1- level)))))))
+			     (backquote-comma-at
+			      (if (= 0 level)
+				  (cadr sub-form)
+				(list 'list
+				      (list 'list
+					    (list 'quote 'backquote-comma-at)
+					    (un-backquote-xxx (cadr sub-form) (1- level))))))
+			     (t (list 'list (un-backquote-xxx sub-form level)))))))))))
+     (array
+      (error "Array backquote not implemented."))
+     (t (list 'quote form)))))




From ffjeld at common-lisp.net  Wed Jul 21 13:24:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 06:24:58 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <E1BnH5e-0005w0-00@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Fixed a nasty bug in append.

Date: Wed Jul 21 06:24:58 2004
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.6 movitz/losp/muerte/lists.lisp:1.7
--- movitz/losp/muerte/lists.lisp:1.6	Wed Jul 21 06:17:22 2004
+++ movitz/losp/muerte/lists.lisp	Wed Jul 21 06:24:58 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.6 2004/07/21 13:17:22 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.7 2004/07/21 13:24:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -180,22 +180,25 @@
 	    (previous-copy nil)
 	    (x lists (cdr x))
 	    (x+ (cdr lists) (cdr x+)))
-	   ((endp x+) (cond
-		       (previous-copy
-			(setf (cdr (last previous-copy))
-			  (car x))
-			copied-result)
-		       (copied-result
-			(setf (cdr (last copied-result))
-			  (car x))
-			copied-result)
-		       (t (car x))))
+	   ((endp x+)
+	    (cond
+	     (previous-copy
+	      (setf (cdr (last previous-copy))
+		(car x))
+	      copied-result)
+	     (copied-result
+	      (setf (cdr (last copied-result))
+		(car x))
+	      copied-result)
+	     (t (car x))))
 	 (when (consp (car x))
 	   (let ((copy (copy-list (car x))))
 	     (if previous-copy
 		 (setf (cdr (last previous-copy)) copy)
 	       (setf copied-result copy))
-	     (setf previous-copy copy)))))))
+	     (setf previous-copy copy)
+	     (unless copied-result
+	       (setf copied-result copy))))))))
 
 (defun copy-list (list)
   (if (null list)




From ffjeld at common-lisp.net  Wed Jul 21 13:27:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 06:27:58 -0700
Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt 
Message-ID: <E1BnH8Y-0006rJ-00@common-lisp.net>

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

Modified Files:
	bochsrc.txt 
Log Message:
Believe it or not, the CVS tag in the header caused Bochs to pause
during start-up about 30 seconds.  Isn't the babylonic world of unix
wonderful? I mean, READ was invented what, 40 years ago? Oh well.

Date: Wed Jul 21 06:27:58 2004
Author: ffjeld

Index: movitz/bochsrc.txt
diff -u movitz/bochsrc.txt:1.5 movitz/bochsrc.txt:1.6
--- movitz/bochsrc.txt:1.5	Wed Jul 21 04:45:52 2004
+++ movitz/bochsrc.txt	Wed Jul 21 06:27:58 2004
@@ -12,8 +12,6 @@
 ## Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ## Created at:    Wed Jul 21 13:41:59 2004
 ##                
-## $Id: bochsrc.txt,v 1.5 2004/07/21 11:45:52 ffjeld Exp $
-##                
 ######################################################################
 
 # how much memory the emulated machine will have




From ffjeld at common-lisp.net  Wed Jul 21 13:28:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 06:28:45 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BnH9J-0001hs-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Try to actually expand backquote expressions run-time.

Date: Wed Jul 21 06:28:44 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.28 movitz/losp/muerte/basic-macros.lisp:1.29
--- movitz/losp/muerte/basic-macros.lisp:1.28	Tue Jul 20 16:50:56 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 21 06:28:44 2004
@@ -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.28 2004/07/20 23:50:56 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.29 2004/07/21 13:28:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -966,8 +966,7 @@
   (error "numargs-case at illegal position."))
 
 (defmacro movitz-backquote (expression)
-  (declare (ignore expression))
-  `(warn "movitz-backquote!"))
+  `(un-backquote ',expression 0))
 
 (define-compiler-macro spin-wait-pause ()
   "Insert a pause instruction, which improves performance of




From ffjeld at common-lisp.net  Wed Jul 21 14:14:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:14:29 -0700
Subject: [movitz-cvs] CVS update: movitz/eval.lisp 
Message-ID: <E1BnHrZ-0003h6-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Teach movitz-eval and movitz-constantp about coerce.

Date: Wed Jul 21 07:14:29 2004
Author: ffjeld

Index: movitz/eval.lisp
diff -u movitz/eval.lisp:1.6 movitz/eval.lisp:1.7
--- movitz/eval.lisp:1.6	Wed Apr 14 14:56:08 2004
+++ movitz/eval.lisp	Wed Jul 21 07:14:29 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  2 17:45:05 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: eval.lisp,v 1.6 2004/04/14 21:56:08 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.7 2004/07/21 14:14:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -66,7 +66,7 @@
 	      ((muerte.cl:quote) t)
 	      ((muerte.cl:not)
 	       (movitz-constantp (second form)))
-	      ((muerte.cl:+ muerte.cl:- muerte.cl:*)
+	      ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce)
 	       (every (lambda (sub-form)
 			(movitz-constantp sub-form environment))
 		      (cdr form)))))
@@ -146,5 +146,9 @@
     (apply (translate-program (car form) :muerte.cl :cl)
 	   (mapcar (lambda (sub-form)
 		     (movitz-eval sub-form env nil))
+		   (cdr form))))
+   ((muerte.cl:coerce)
+    (apply #'coerce
+	   (mapcar (lambda (arg) (movitz-eval arg env nil))
 		   (cdr form))))
    (t (error "Don't know how to compile constant compound form ~A" form))))




From ffjeld at common-lisp.net  Wed Jul 21 14:15:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:15:13 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BnHsH-0002Eq-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Use aref rather than svref, we don't know that the vector is simple.

Date: Wed Jul 21 07:15:13 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.28 movitz/storage-types.lisp:1.29
--- movitz/storage-types.lisp:1.28	Mon Jul 12 19:26:19 2004
+++ movitz/storage-types.lisp	Wed Jul 21 07:15:13 2004
@@ -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.28 2004/07/13 02:26:19 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.29 2004/07/21 14:15:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -396,8 +396,8 @@
 (defmethod update-movitz-object ((movitz-vector movitz-basic-vector) (vector vector))
   (when (eq :any-t (movitz-vector-element-type movitz-vector))
     (loop for i from 0 below (length vector)
-	do (setf (svref (movitz-vector-symbolic-data movitz-vector) i)
-	     (movitz-read (svref vector i)))))
+	do (setf (aref (movitz-vector-symbolic-data movitz-vector) i)
+	     (movitz-read (aref vector i)))))
   (values))
 
 (defmethod write-binary-record ((obj movitz-basic-vector) stream)




From ffjeld at common-lisp.net  Wed Jul 21 14:15:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:15:37 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <E1BnHsf-0004Se-00@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Moved un-backquote to read.lisp.

Date: Wed Jul 21 07:15:37 2004
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.7 movitz/losp/muerte/lists.lisp:1.8
--- movitz/losp/muerte/lists.lisp:1.7	Wed Jul 21 06:24:58 2004
+++ movitz/losp/muerte/lists.lisp	Wed Jul 21 07:15:37 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.7 2004/07/21 13:24:58 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.8 2004/07/21 14:15:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -455,61 +455,3 @@
 	list
       (cons item list))))
 
-
-(defun ub (x)
-  `(hello world))
-
-(defun un-backquote (expr level)
-  (eval (un-backquote-xxx expr level)))
-
-(defun un-backquote-xxx (form level)
-  "Dont ask.."
-  (declare (notinline un-backquote))
-  (assert (not (minusp level)))
-  (values
-   (typecase form
-     (null nil)
-     (list
-      (case (car form)
-	(backquote-comma
-	 (cadr form))
-	(t (cons 'append
-		 (loop for sub-form-head on form
-		     as sub-form = (and (consp sub-form-head)
-					(car sub-form-head))
-		     collecting
-		       (cond
-			((atom sub-form-head)
-			 (list 'quote sub-form-head))
-			((atom sub-form)
-			 (list 'quote (list sub-form)))
-			(t (case (car sub-form)
-			     (muerte::movitz-backquote
-			      (list 'list
-				    (list 'list (list 'quote 'muerte::movitz-backquote)
-					  (un-backquote-xxx (cadr sub-form) (1+ level)))))
-			     (backquote-comma
-			      (cond
-			       ((= 0 level)
-				(list 'list (cadr sub-form)))
-			       ((and (listp (cadr sub-form))
-				     (eq 'backquote-comma-at (caadr sub-form)))
-				(list 'append
-				      (list 'mapcar
-					    '(lambda (x) (list 'backquote-comma x))
-					    (cadr (cadr sub-form)))))
-			       (t (list 'list
-					(list 'list
-					      (list 'quote 'backquote-comma)
-					      (un-backquote-xxx (cadr sub-form) (1- level)))))))
-			     (backquote-comma-at
-			      (if (= 0 level)
-				  (cadr sub-form)
-				(list 'list
-				      (list 'list
-					    (list 'quote 'backquote-comma-at)
-					    (un-backquote-xxx (cadr sub-form) (1- level))))))
-			     (t (list 'list (un-backquote-xxx sub-form level)))))))))))
-     (array
-      (error "Array backquote not implemented."))
-     (t (list 'quote form)))))




From ffjeld at common-lisp.net  Wed Jul 21 14:15:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:15:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <E1BnHsl-0004lF-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Moved un-backquote to read.lisp.

Date: Wed Jul 21 07:15:43 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.5 movitz/losp/muerte/read.lisp:1.6
--- movitz/losp/muerte/read.lisp:1.5	Thu Jul  8 06:38:15 2004
+++ movitz/losp/muerte/read.lisp	Wed Jul 21 07:15:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.5 2004/07/08 13:38:15 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.6 2004/07/21 14:15:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -314,3 +314,55 @@
 ;;;      (error 'end-of-file :stream stream))
 ;;;     (t eof-value))))
 
+
+(defun un-backquote (form level)
+  "Dont ask.."
+  (declare (notinline un-backquote))
+  (assert (not (minusp level)))
+  (values
+   (typecase form
+     (null nil)
+     (list
+      (case (car form)
+	(backquote-comma
+	 (cadr form))
+	(t (cons 'append
+		 (loop for sub-form-head on form
+		     as sub-form = (and (consp sub-form-head)
+					(car sub-form-head))
+		     collecting
+		       (cond
+			((atom sub-form-head)
+			 (list 'quote sub-form-head))
+			((atom sub-form)
+			 (list 'quote (list sub-form)))
+			(t (case (car sub-form)
+			     (muerte::movitz-backquote
+			      (list 'list
+				    (list 'list (list 'quote 'muerte::movitz-backquote)
+					  (un-backquote-xxx (cadr sub-form) (1+ level)))))
+			     (backquote-comma
+			      (cond
+			       ((= 0 level)
+				(list 'list (cadr sub-form)))
+			       ((and (listp (cadr sub-form))
+				     (eq 'backquote-comma-at (caadr sub-form)))
+				(list 'append
+				      (list 'mapcar
+					    '(lambda (x) (list 'backquote-comma x))
+					    (cadr (cadr sub-form)))))
+			       (t (list 'list
+					(list 'list
+					      (list 'quote 'backquote-comma)
+					      (un-backquote-xxx (cadr sub-form) (1- level)))))))
+			     (backquote-comma-at
+			      (if (= 0 level)
+				  (cadr sub-form)
+				(list 'list
+				      (list 'list
+					    (list 'quote 'backquote-comma-at)
+					    (un-backquote-xxx (cadr sub-form) (1- level))))))
+			     (t (list 'list (un-backquote-xxx sub-form level)))))))))))
+     (array
+      (error "Array backquote not implemented."))
+     (t (list 'quote form)))))




From ffjeld at common-lisp.net  Wed Jul 21 14:16:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:16:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1BnHtH-0000Dx-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Don't use @ as an operator name, it's a good reader macro candidate.

Date: Wed Jul 21 07:16:15 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.16 movitz/losp/muerte/interrupt.lisp:1.17
--- movitz/losp/muerte/interrupt.lisp:1.16	Tue Jul 20 01:54:19 2004
+++ movitz/losp/muerte/interrupt.lisp	Wed Jul 21 07:16:15 2004
@@ -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.16 2004/07/20 08:54:19 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.17 2004/07/21 14:16:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -254,7 +254,7 @@
 
 (defun interrupt-default-handler (number interrupt-frame)
   (declare (without-check-stack-limit))
-  (macrolet ((@ (fixnum-address &optional (type :lisp))
+  (macrolet ((dereference (fixnum-address &optional (type :lisp))
 	       "Dereference the fixnum-address."
 	       `(memref ,fixnum-address 0 0 ,type)))
     (let (($eip (+ interrupt-frame (interrupt-frame-index :eip)))
@@ -277,15 +277,15 @@
 	  ((61)
 	   ;; 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 (@ $eax) :expected-type (@ $edx)))
+	     (error 'type-error :datum (dereference $eax) :expected-type (dereference $edx)))
 	   (format *query-io* "Enter a new value: ")
-	   (setf (@ $eax) (read *query-io*)))
+	   (setf (dereference $eax) (read *query-io*)))
 	  (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 (@ $eax) :expected-type 'integer))
-	  (65 (error 'index-out-of-range :index (@ $ebx) (@ $ecx)))
+	  (64 (error 'type-error :datum (dereference $eax) :expected-type 'integer))
+	  (65 (error 'index-out-of-range :index (dereference $ebx) (dereference $ecx)))
 	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
-		     $eip (@ (+ interrupt-frame (interrupt-frame-index :esi)))
+		     $eip (dereference (+ interrupt-frame (interrupt-frame-index :esi)))
 		     $eax $ecx))
 	  (67 (backtrace :fresh-lines nil :length 6)
 	      (dotimes (i 100000)
@@ -323,19 +323,19 @@
 		       old-bottom)
 	       (setf (stack-bottom) old-bottom))))
 	  (69
-	   (error "Not a function: ~S" (@ $edx)))
+	   (error "Not a function: ~S" (dereference $edx)))
 	  (70
-	   (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (@ $eax)))
+	   (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (dereference $eax)))
 	  (98
-	   (let ((name (@ $edx)))
+	   (let ((name (dereference $edx)))
 	     (when (symbolp name)
 	       (error 'undefined-function :name name))))
 	  (99
-	   (let ((name (@ $edx)))
+	   (let ((name (dereference $edx)))
 	     (when (symbolp name)
 	       (error 'unbound-variable :name name))))
 	  ((100);; 101 102 103 104 105)
-	   (let ((funobj (@ (+ interrupt-frame (interrupt-frame-index :esi))))
+	   (let ((funobj (dereference (+ interrupt-frame (interrupt-frame-index :esi))))
 		 (code (interrupt-frame-ref :ecx :unsigned-byte8 0 interrupt-frame)))
 	     (error 'wrong-argument-count
 		    :function funobj
@@ -345,7 +345,7 @@
 					     -24)
 				      code))))
 	  (108
-	   (error 'throw-error :tag (@ $eax)))
+	   (error 'throw-error :tag (dereference $eax)))
 	  (110
 	   ;; (print-dynamic-context); what's this?
 	   (throw :debugger nil))




From ffjeld at common-lisp.net  Wed Jul 21 14:16:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:16:57 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BnHtx-0002L2-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Don't try to mirror deftype of names in the common-lisp package on the
host side.

Date: Wed Jul 21 07:16:57 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.29 movitz/losp/muerte/typep.lisp:1.30
--- movitz/losp/muerte/typep.lisp:1.29	Wed Jul 21 05:49:24 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 21 07:16:57 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.29 2004/07/21 12:49:24 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.30 2004/07/21 14:16:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -426,7 +426,8 @@
   (let ((fname (intern (format nil "~A-~A" 'deftype name))))
     `(progn
        (eval-when (:compile-toplevel)
-	 ,form
+	 (unless (eq (symbol-package ',name) (find-package :common-lisp))
+	   ,form)
 	 (setf (gethash (translate-program ',name :cl :muerte.cl)
 			*compiler-derived-typespecs*)
 	   (lambda ,lambda , at body))




From ffjeld at common-lisp.net  Wed Jul 21 14:17:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:17:35 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BnHuZ-0004rW-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Correct movitz-backquote macro.

Date: Wed Jul 21 07:17:35 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.29 movitz/losp/muerte/basic-macros.lisp:1.30
--- movitz/losp/muerte/basic-macros.lisp:1.29	Wed Jul 21 06:28:44 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 21 07:17:35 2004
@@ -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.29 2004/07/21 13:28:44 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.30 2004/07/21 14:17:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -966,7 +966,7 @@
   (error "numargs-case at illegal position."))
 
 (defmacro movitz-backquote (expression)
-  `(un-backquote ',expression 0))
+  (un-backquote expression 0))
 
 (define-compiler-macro spin-wait-pause ()
   "Insert a pause instruction, which improves performance of




From ffjeld at common-lisp.net  Wed Jul 21 14:18:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 07:18:03 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BnHv1-00064w-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved deftypes so they work on both movitz and host-sides.

Date: Wed Jul 21 07:18:03 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.80 movitz/losp/muerte/integers.lisp:1.81
--- movitz/losp/muerte/integers.lisp:1.80	Tue Jul 20 02:19:00 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 21 07:18:03 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.80 2004/07/20 09:19:00 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.81 2004/07/21 14:18:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -344,13 +344,13 @@
 ;;;;
 
 (deftype positive-fixnum ()
-  `(integer 0 ,movitz:+movitz-most-positive-fixnum+))
+  '(integer 0 #.movitz:+movitz-most-positive-fixnum+))
 
 (deftype positive-bignum ()
-  `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *))
+  `(integer #.(cl:1+ movitz:+movitz-most-positive-fixnum+) *))
 
 (deftype negative-fixnum ()
-  `(integer ,movitz:+movitz-most-negative-fixnum+ -1))
+  `(integer #.movitz:+movitz-most-negative-fixnum+ -1))
 
 (defun fixnump (x)
   (typep x 'fixnum))




From ffjeld at common-lisp.net  Wed Jul 21 22:26:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:26:56 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BnPY8-0005sd-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Small fix to "unused variable" warning.

Date: Wed Jul 21 15:26:55 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.80 movitz/compiler.lisp:1.81
--- movitz/compiler.lisp:1.80	Tue Jul 20 05:59:53 2004
+++ movitz/compiler.lisp	Wed Jul 21 15:26:55 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.80 2004/07/20 12:59:53 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.81 2004/07/21 22:26:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2821,7 +2821,8 @@
 				      (unless (or (movitz-env-get variable 'ignore nil env nil)
 						  (movitz-env-get variable 'ignorable nil env nil)
 						  (typep binding 'hidden-rest-function-argument))
-					(warn "Unused variable: ~S" binding)))))
+					(warn "Unused variable: ~S"
+					      (binding-name binding))))))
 			   collect binding))
 		      (bindings-fun-arg-sorted
 		       (when (eq env function-env)
@@ -5884,7 +5885,7 @@
 				 (and (typep binding 'forwarding-binding)
 				      (recursive-located-p (forwarding-binding-target b))))))
 		    (recursive-located-p binding)))
-	(warn "Unused variable: ~S." binding)))
+	(warn "Unused variable: ~S." (binding-name binding))))
      ((typep binding 'forwarding-binding)
       ;; No need to do any initialization because the target will be initialized.
       (assert (not (binding-lended-p binding)))




From ffjeld at common-lisp.net  Wed Jul 21 22:28:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:28:48 -0700
Subject: [movitz-cvs] CVS update: movitz/movitz.lisp 
Message-ID: <E1BnPZw-00079R-00@common-lisp.net>

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

Modified Files:
	movitz.lisp 
Log Message:
Fixed un-backquote for non-proper lists, like `(a b . c).

Date: Wed Jul 21 15:28:48 2004
Author: ffjeld

Index: movitz/movitz.lisp
diff -u movitz/movitz.lisp:1.7 movitz/movitz.lisp:1.8
--- movitz/movitz.lisp:1.7	Wed Apr 21 08:09:25 2004
+++ movitz/movitz.lisp	Wed Jul 21 15:28:48 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Oct  9 20:52:58 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: movitz.lisp,v 1.7 2004/04/21 15:09:25 ffjeld Exp $
+;;;; $Id: movitz.lisp,v 1.8 2004/07/21 22:28:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -132,7 +132,10 @@
 				      (list 'list
 					    (list 'quote 'backquote-comma-at)
 					    (un-backquote (cadr sub-form) (1- level))))))
-			     (t (list 'list (un-backquote sub-form level)))))))))))
+			     (t (list 'list (un-backquote sub-form level))))))
+		     when (not (listp (cdr sub-form-head)))
+		     collect (list 'quote (cdr sub-form-head)))
+		 ))))
      (array
       (error "Array backquote not implemented."))
      (t (list 'quote form)))))




From ffjeld at common-lisp.net  Wed Jul 21 22:29:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:29:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/package.lisp 
Message-ID: <E1BnPaO-0002Af-00@common-lisp.net>

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

Modified Files:
	package.lisp 
Log Message:
Made repl a separate package.

Date: Wed Jul 21 15:29:16 2004
Author: ffjeld

Index: movitz/losp/lib/package.lisp
diff -u movitz/losp/lib/package.lisp:1.3 movitz/losp/lib/package.lisp:1.4
--- movitz/losp/lib/package.lisp:1.3	Mon Jan 19 03:23:44 2004
+++ movitz/losp/lib/package.lisp	Wed Jul 21 15:29:16 2004
@@ -10,12 +10,13 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Sep 27 17:24:11 2002
 ;;;;                
-;;;; $Id: package.lisp,v 1.3 2004/01/19 11:23:44 ffjeld Exp $
+;;;; $Id: package.lisp,v 1.4 2004/07/21 22:29:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
-(defpackage muerte.lib
-  (:use muerte.cl muerte)
+(defpackage #:muerte.lib
+  (:nicknames #:lib)
+  (:use #:common-lisp #:muerte)
   (:export #:*scroll-offset*
 	   #:cursor-x cursor-y
 	   #:console-width console-height
@@ -58,12 +59,12 @@
 	   #:with-named-integers-syntax
 	   
 	   ;; :lib/repl
-	   #:*repl-level*
-	   #:*repl-prompter*
-	   #:*repl-prompt-context*
-	   #:*repl-print-format*
-	   #:*repl-readline-context*
-	   #:read-eval-print
+;;;	   #:*repl-level*
+;;;	   #:*repl-prompter*
+;;;	   #:*repl-prompt-context*
+;;;	   #:*repl-print-format*
+;;;	   #:*repl-readline-context*
+;;;	   #:read-eval-print
 	   ))
 
 (provide :lib/package)




From ffjeld at common-lisp.net  Wed Jul 21 22:29:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:29:20 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1BnPaS-0004P3-00@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Made repl a separate package.

Date: Wed Jul 21 15:29:20 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.11 movitz/losp/lib/repl.lisp:1.12
--- movitz/losp/lib/repl.lisp:1.11	Fri Apr 23 07:59:35 2004
+++ movitz/losp/lib/repl.lisp	Wed Jul 21 15:29:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.11 2004/04/23 14:59:35 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.12 2004/07/21 22:29:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,18 @@
 (require :lib/readline)
 (provide :lib/repl)
 
-(in-package muerte.lib)
+(defpackage #:muerte.repl
+  (:documentation "Implementation of Read Eval Print Loop.")
+  (:nicknames #:repl)
+  (:use #:common-lisp #:muerte)
+  (:export #:*repl-level*
+	   #:*repl-prompter*
+	   #:*repl-prompt-context*
+	   #:*repl-print-format*
+	   #:*repl-readline-context*
+	   #:read-eval-print))
+
+(in-package #:muerte.repl)
 
 (defparameter *repl-level* -1)
 (defparameter *repl-prompter* 'default-repl-prompter)




From ffjeld at common-lisp.net  Wed Jul 21 22:30:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:30:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BnPbL-0001WJ-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Made defpackage a bit smarter about recognizing nicknames.

Date: Wed Jul 21 15:30:15 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.30 movitz/losp/muerte/basic-macros.lisp:1.31
--- movitz/losp/muerte/basic-macros.lisp:1.30	Wed Jul 21 07:17:35 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 21 15:30:14 2004
@@ -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.30 2004/07/21 14:17:35 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.31 2004/07/21 22:30:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -73,7 +73,8 @@
   (pushnew '(:use) options :key #'car)
   (let ((uses (cdr (assoc :use options))))
     (setf uses (mapcar (lambda (use)
-			 (if (member use '(:cl :common-lisp) :test #'string=)
+			 (if (member use (cons :common-lisp (package-nicknames :common-lisp))
+				     :test #'string=)
 			     :muerte.cl
 			   use))
 		       uses))




From ffjeld at common-lisp.net  Wed Jul 21 22:30:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:30:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BnPbw-0001eC-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved the number-relational compiler-macros.

Date: Wed Jul 21 15:30:52 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.81 movitz/losp/muerte/integers.lisp:1.82
--- movitz/losp/muerte/integers.lisp:1.81	Wed Jul 21 07:18:03 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jul 21 15:30:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.81 2004/07/21 14:18:03 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.82 2004/07/21 22:30:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -232,20 +232,31 @@
 (defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
   `(progn
      ,(when condition
-	`(define-compiler-macro ,2op-name (n1 n2)
+	`(define-compiler-macro ,2op-name (n1 n2 &environment env)
 	   (cond
-	    ((movitz:movitz-constantp n1)
-	     (let ((n1 (movitz::movitz-eval n1)))
-	       (check-type n1 (signed-byte 30))
-	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-fixnum-real))))
-	    ((movitz:movitz-constantp n2)
-	     (let ((n2 (movitz::movitz-eval n2)))
-	       (check-type n2 (signed-byte 30))
-	       `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-real-fixnum))))
+	    ((and (movitz:movitz-constantp n1 env)
+		  (movitz:movitz-constantp n2 env))
+	     (list ',2op-name (movitz:movitz-eval n1 env) (movitz:movitz-eval n2 env)))
+	    ((movitz:movitz-constantp n1 env)
+	     (let ((n1 (movitz::movitz-eval n1 env)))
+	       (check-type n1 number)
+	       (if (typep n1 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-fixnum-real))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
+	    ((movitz:movitz-constantp n2 env)
+	     (let ((n2 (movitz:movitz-eval n2 env)))
+	       (check-type n2 number)
+	       (if (typep n2 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-real-fixnum))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
 	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
 		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
 		  (:call-global-pf fast-compare-two-reals))))))




From ffjeld at common-lisp.net  Wed Jul 21 22:33:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:33:55 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BnPet-000658-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Made array-element-type recognize bit-vectors.
Wrote upgraded-array-element-type, and array-dimensions.
Added a typep for array.

Date: Wed Jul 21 15:33:55 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.38 movitz/losp/muerte/arrays.lisp:1.39
--- movitz/losp/muerte/arrays.lisp:1.38	Wed Jul 21 04:47:49 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul 21 15:33:55 2004
@@ -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.38 2004/07/21 11:47:49 lgorrie Exp $
+;;;; $Id: arrays.lisp,v 1.39 2004/07/21 22:33:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,15 +65,61 @@
        '(unsigned-byte 16))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
        '(unsigned-byte 32))
+    (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
+       'bit)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
        'code)))
 
+(defun upgraded-array-element-type (type-specifier &optional environment)
+  "=> upgraded-type-specifier"
+  ;; We're in dire need of subtypep..
+  (cond
+   ((symbolp type-specifier)
+    (case type-specifier
+      ((character base-char standard-char)
+       'character)
+      ((code)
+       'code)
+      (t (let ((deriver (gethash type-specifier *derived-typespecs*)))
+	   (if (not deriver)
+	       t
+	     (upgraded-array-element-type (funcall deriver)))))))
+   ((null type-specifier)
+    t)
+   ((consp type-specifier)
+    (case (car type-specifier)
+      ((integer)
+       (let* ((q (cdr type-specifier))
+	      (min (if q (pop q) '*))
+	      (max (if q (pop q) '*)))
+	 (cond
+	  ((or (eq min '*) (eq max '*))
+	   t)
+	  ((<= 0 min max 1)
+	   'bit)
+	  ((<= 0 min max #xff)
+	   '(unsigned-byte 8))
+	  ((<= 0 min max #xffff)
+	   '(unsigned-byte 16))
+	  ((<= 0 min max #xffffffff)
+	   '(unsigned-byte 32)))))
+      (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*)))
+	   (if (not deriver)
+	       t
+	     (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment))))))
+   (t t)))
+    
+
 (defun array-dimension (array axis-number)
   (etypecase array
-    (simple-array
+    ((simple-array * 1)
      (assert (zerop axis-number))
      (movitz-accessor array movitz-basic-vector num-elements))))
 
+(defun array-dimensions (array)
+  (check-type array array)
+  1)
+
 (defun shrink-vector (vector new-size)
   (setf-movitz-accessor (vector movitz-basic-vector num-elements) new-size)
   vector)
@@ -772,3 +818,19 @@
 (defun bvref-u16 (vector offset index)
   "View <vector> as an sequence of octets, access the big-endian 16-bit word at position <index> + <offset>."
   (bvref-u16 vector offset index))
+
+(define-typep array (x &optional (element-type '*) (dimension-spec '*))
+  (and (typep x 'array)
+       (or (eq element-type '*)
+	   (eq element-type t)
+	   (equalp (array-element-type x)
+		   (upgraded-array-element-type element-type)))
+       (or (eq dimension-spec '*)
+	   (and (integerp dimension-spec)
+		(= dimension-spec (array-dimensions x)))
+	   (and (listp dimension-spec)
+		(do ((d 0 (1+ d))
+		     (q dimension-spec))
+		    ((null q) t)
+		  (unless (= (pop q) (array-dimension x d))
+		    (return nil)))))))




From ffjeld at common-lisp.net  Wed Jul 21 22:35:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:35:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <E1BnPgB-00022F-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Fixed un-backquote for non-proper lists, like `(a b . c).

Date: Wed Jul 21 15:35:15 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.6 movitz/losp/muerte/read.lisp:1.7
--- movitz/losp/muerte/read.lisp:1.6	Wed Jul 21 07:15:43 2004
+++ movitz/losp/muerte/read.lisp	Wed Jul 21 15:35:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.6 2004/07/21 14:15:43 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.7 2004/07/21 22:35:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,9 @@
 
 (in-package muerte)
 
+(defvar *read-suppress*)
+(defvar *readtable*)
+
 (defun substring (string start end)
   (if (and (zerop start) (= end (length string)))
       string
@@ -302,19 +305,6 @@
       (t (return-from simple-read-from-string
 	   (simple-read-token string :start i :end end))))))
 
-;;;(defun read-char (&optional input-stream eof-error-p eof-value recursive-p)
-;;;  " => char"
-;;;  (declare (ignore recursive-p))
-;;;  (let* ((stream (input-stream-designator input-stream))
-;;;	 (char (stream-read-char stream)))
-;;;    (cond
-;;;     ((not (eq :eof char))
-;;;      char)
-;;;     (eof-error-p
-;;;      (error 'end-of-file :stream stream))
-;;;     (t eof-value))))
-
-
 (defun un-backquote (form level)
   "Dont ask.."
   (declare (notinline un-backquote))
@@ -340,7 +330,7 @@
 			     (muerte::movitz-backquote
 			      (list 'list
 				    (list 'list (list 'quote 'muerte::movitz-backquote)
-					  (un-backquote-xxx (cadr sub-form) (1+ level)))))
+					  (un-backquote (cadr sub-form) (1+ level)))))
 			     (backquote-comma
 			      (cond
 			       ((= 0 level)
@@ -354,15 +344,19 @@
 			       (t (list 'list
 					(list 'list
 					      (list 'quote 'backquote-comma)
-					      (un-backquote-xxx (cadr sub-form) (1- level)))))))
+					      (un-backquote (cadr sub-form) (1- level)))))))
 			     (backquote-comma-at
 			      (if (= 0 level)
 				  (cadr sub-form)
 				(list 'list
 				      (list 'list
 					    (list 'quote 'backquote-comma-at)
-					    (un-backquote-xxx (cadr sub-form) (1- level))))))
-			     (t (list 'list (un-backquote-xxx sub-form level)))))))))))
+					    (un-backquote (cadr sub-form) (1- level))))))
+			     (t (list 'list (un-backquote sub-form level))))))
+		     when (not (listp (cdr sub-form-head)))
+		     collect (list 'quote (cdr sub-form-head)))
+		 ))))
      (array
       (error "Array backquote not implemented."))
      (t (list 'quote form)))))
+




From ffjeld at common-lisp.net  Wed Jul 21 22:36:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:36:00 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BnPgu-0008Uz-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Made typep compiler-macro slighty smarter about (array ...) type-specifiers.

Date: Wed Jul 21 15:36:00 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.30 movitz/losp/muerte/typep.lisp:1.31
--- movitz/losp/muerte/typep.lisp:1.30	Wed Jul 21 07:16:57 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 21 15:36:00 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.30 2004/07/21 14:16:57 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.31 2004/07/21 22:36:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -276,6 +276,8 @@
 		       (if (not (eql dim 1))
 			   form
 			 (cond
+			  ((eq et '*)
+			   (make-other-typep :basic-vector))
 			  ((movitz:movitz-subtypep et '(unsigned-byte 8))
 			   (make-basic-vector-typep :u8))
 			  ((movitz:movitz-subtypep et '(unsigned-byte 32))
@@ -560,6 +562,8 @@
 
 (define-simple-typep (hash-table hash-table-p))
 (define-simple-typep (package packagep))
+
+;;;
 
 (define-typep and (x &rest types)
   (declare (dynamic-extent types))




From ffjeld at common-lisp.net  Wed Jul 21 22:37:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 15:37:07 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp 
Message-ID: <E1BnPhz-000653-00@common-lisp.net>

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

Modified Files:
	packet.lisp 
Log Message:
Don't entirely skip the reader-macro stuff for the movitz side.

Date: Wed Jul 21 15:37:07 2004
Author: ffjeld

Index: movitz/losp/tmp/packet.lisp
diff -u movitz/losp/tmp/packet.lisp:1.2 movitz/losp/tmp/packet.lisp:1.3
--- movitz/losp/tmp/packet.lisp:1.2	Wed Jul 21 05:33:54 2004
+++ movitz/losp/tmp/packet.lisp	Wed Jul 21 15:37:06 2004
@@ -270,7 +270,7 @@
 ;;;
 ;;; The read syntax is `#e"ff:00:1:2:3:4'.
 ;;;
-(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (defstruct (ethernet-address (:conc-name #:ethernet-address.)
                                (:print-function print-ethernet-address))
     "48-bit Ethernet MAC address."
@@ -291,7 +291,8 @@
               (setf (elt vec i) octet))))
         (unless *read-suppress*
           (make-ethernet-address :octets vec)))))
-  
+
+  #-movitz
   (set-dispatch-macro-character #\# #\e 'read-ethernet-address)
 
   (defun print-ethernet-address (address stream depth)
@@ -397,7 +398,7 @@
 ;;;
 ;;; IP addresses also have a special read-syntax: `@10.0.0.1'.
 ;;;
-(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (defstruct (ipv4-address (:conc-name #:ipv4-address.)
                            (:print-function print-ipv4-address))
     (octets 0 :type (array octet (4))))
@@ -416,6 +417,7 @@
         (unless *read-suppress*
           (make-ipv4-address :octets vec)))))
   
+  #-movitz
   (set-macro-character #\@ 'read-ipv4-address t)
 
   (defun print-ipv4-address (address stream depth)




From ffjeld at common-lisp.net  Thu Jul 22 00:27:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:27:12 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BnRQW-0000k8-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Changed the signature and workings of make-movitz-vector somewhat: Now
the element-type argument is an actual (host) type-specifier.
The idea is that movitz-read of an array will result in a movitz array
with the corresponding element-type.

Date: Wed Jul 21 17:27:11 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.81 movitz/compiler.lisp:1.82
--- movitz/compiler.lisp:1.81	Wed Jul 21 15:26:55 2004
+++ movitz/compiler.lisp	Wed Jul 21 17:27:11 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.81 2004/07/21 22:26:55 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.82 2004/07/22 00:27:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -108,7 +108,7 @@
 						  (case label
 						    (:nil-value (image-nil-word *image*)))))))
     (make-movitz-vector (length code-vector)
-			:element-type 'movitz-code
+			:element-type 'code
 			:initial-contents code-vector)))
 
 (defun register-function-code-size (funobj)
@@ -873,7 +873,7 @@
       (setf (movitz-funobj-code-vector funobj)
 	(make-movitz-vector (length code-vector)
 			    :fill-pointer code-length
-			    :element-type 'movitz-code
+			    :element-type 'code
 			    :initial-contents code-vector
 			    ))))
   funobj)




From ffjeld at common-lisp.net  Thu Jul 22 00:27:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:27:17 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BnRQb-00018C-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Changed the signature and workings of make-movitz-vector somewhat: Now
the element-type argument is an actual (host) type-specifier.
The idea is that movitz-read of an array will result in a movitz array
with the corresponding element-type.

Date: Wed Jul 21 17:27:17 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.48 movitz/image.lisp:1.49
--- movitz/image.lisp:1.48	Wed Jul 21 05:32:26 2004
+++ movitz/image.lisp	Wed Jul 21 17:27:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.48 2004/07/21 12:32:26 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.49 2004/07/22 00:27:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1438,7 +1438,8 @@
 		     (setf (gethash expr (image-string-constants *image*))
 		       (make-movitz-string expr))))
 	 (vector (make-movitz-vector (length expr)
-				     :initial-contents (map 'vector #'movitz-read expr)))
+				     :element-type (array-element-type expr)
+				     :initial-contents expr))
 	 (cons
 	  (or (gethash expr (image-cons-constants *image*))
 	      (setf (gethash expr (image-cons-constants *image*))




From ffjeld at common-lisp.net  Thu Jul 22 00:27:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:27:22 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BnRQg-0001OQ-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Changed the signature and workings of make-movitz-vector somewhat: Now
the element-type argument is an actual (host) type-specifier.
The idea is that movitz-read of an array will result in a movitz array
with the corresponding element-type.

Date: Wed Jul 21 17:27:22 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.29 movitz/storage-types.lisp:1.30
--- movitz/storage-types.lisp:1.29	Wed Jul 21 07:15:13 2004
+++ movitz/storage-types.lisp	Wed Jul 21 17:27:22 2004
@@ -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.29 2004/07/21 14:15:13 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.30 2004/07/22 00:27:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -441,18 +441,30 @@
 	      8)))
 
 (defun movitz-vector-upgrade-type (type)
-  (case type
-    (movitz-unboxed-integer-u8
-     (values :u8 0))
-    (movitz-unboxed-integer-u32
-     (values :u32 0))
-    (movitz-character
-     (values :character #\null))
-    (movitz-code
-     (values :code 0))
-    (t (values :any-t nil))))
+  (cond
+   ((eq type 'code)
+    (values :code 0))
+   ((subtypep type '(unsigned-byte 8))
+    (values :u8 0))
+   ((subtypep type '(unsigned-byte 16))
+    (values :u16 0))
+   ((subtypep type '(unsigned-byte 32))
+    (values :u32 0))
+   ((subtypep type 'character)
+    (values :character #\null))
+   (t (values :any-t nil)))
+  #+ignore (case type
+	     (movitz-unboxed-integer-u8
+	      (values :u8 0))
+	     (movitz-unboxed-integer-u32
+	      (values :u32 0))
+	     (movitz-character
+	      (values :character #\null))
+	     (movitz-code
+	      (values :code 0))
+	     (t (values :any-t nil))))
 
-(defun make-movitz-vector (size &key (element-type 'movitz-object)
+(defun make-movitz-vector (size &key (element-type t)
 				     (initial-contents nil)
 				     (initial-element *movitz-nil* initial-element-p)
 				     (alignment 8)
@@ -462,13 +474,13 @@
   (assert (or (null initial-contents)
 	      (= size (length initial-contents))) (size initial-contents)
     "The initial-contents must be the same length as SIZE.")
-  (assert (subtypep element-type 'movitz-object) ()
-    "ELEMENT-TYPE must be a subtype of MOVITZ-OBJECT.")
-  (assert (or initial-contents
-	      (not initial-element-p)
-	      (typep initial-element element-type)) ()
-    "INITIAL-ELEMENT's type ~A is not of ELEMENT-TYPE ~A."
-    (type-of initial-element) element-type)
+;;;  (assert (subtypep element-type 'movitz-object) ()
+;;;    "ELEMENT-TYPE must be a subtype of MOVITZ-OBJECT.")
+;;;  (assert (or initial-contents
+;;;	      (not initial-element-p)
+;;;	      (typep initial-element element-type)) ()
+;;;    "INITIAL-ELEMENT's type ~A is not of ELEMENT-TYPE ~A."
+;;;    (type-of initial-element) element-type)
   (assert (and (>= (log alignment 2) 3)
 	       (zerop (rem (log alignment 2) 1)))
       (alignment)
@@ -489,14 +501,17 @@
     (make-instance 'movitz-basic-vector
       :element-type et
       :num-elements size
-      :symbolic-data initial-contents ;; sv
+      :symbolic-data (case et
+		       (:any-t
+			(map 'vector #'movitz-read initial-contents))
+		       (t initial-contents))
       :fill-pointer (if (integerp fill-pointer)
 			fill-pointer
 		      size))))
 
 (defun make-movitz-string (string)
   (make-movitz-vector (length string)
-		   :element-type 'movitz-character
+		   :element-type 'character
 		   :initial-contents (map 'list #'identity string)))
 ;; (map 'list #'make-movitz-character string)))
 
@@ -1177,8 +1192,8 @@
 		   bytes)))))
     (let ((l32 (merge-bytes byte-list 8 32)))
       (movitz-intern (make-movitz-vector (length l32)
-				   :element-type 'movitz-unboxed-integer-u32
-				   :initial-contents l32)))))
+					 :element-type '(unsigned-byte 32)
+					 :initial-contents l32)))))
 
 
 ;;; std-instance




From ffjeld at common-lisp.net  Thu Jul 22 00:28:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:28:06 -0700
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1BnRRO-0002Ma-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Minor hacking on backtrace.

Date: Wed Jul 21 17:28:06 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.9 movitz/procfs-image.lisp:1.10
--- movitz/procfs-image.lisp:1.9	Thu Jul  8 11:53:33 2004
+++ movitz/procfs-image.lisp	Wed Jul 21 17:28:06 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.9 2004/07/08 18:53:33 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.10 2004/07/22 00:28:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -169,7 +169,8 @@
   (- 5 (position name
 		 '(nil :eflags :eip :error-code :exception :ebp nil
 		   :ecx :eax :edx :ebx :esi :edi))))
-(defun backtrace ()
+
+(defun backtrace (&key reqs)
   (format t "~&Backtracing from EIP = #x~X: "
 	  (image-register32 *image* :eip))
   ;; (search-image-funobj (image-register32 *image* :eip))
@@ -197,7 +198,11 @@
 		(write-string (symbol-name name))
 		(when (string= name 'toplevel-function)
 		  (loop-finish))
-		(format t " (#x~X)" (stack-frame-return-address stack-frame))))
+		(format t " (#x~X)" (stack-frame-return-address stack-frame))
+		(when reqs
+		  (format t " req1: ~S, req2: ~S"
+			  (movitz-word (get-word stack-frame -2))
+			  (movitz-word (get-word stack-frame -3))))))
 	     (t (write (movitz-print movitz-name)))))
       do (format t "~& => "))
   (values))




From ffjeld at common-lisp.net  Thu Jul 22 00:58:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:58:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <E1BnRvA-0001q5-00@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
Don't use the old vector-u8 stuff.

Date: Wed Jul 21 17:58:50 2004
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.4 movitz/losp/lib/net/arp.lisp:1.5
--- movitz/losp/lib/net/arp.lisp:1.4	Thu Feb 26 03:28:08 2004
+++ movitz/losp/lib/net/arp.lisp	Wed Jul 21 17:58:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.4 2004/02/26 11:28:08 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.5 2004/07/22 00:58:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,7 +43,8 @@
   (if packet
       (setf (fill-pointer packet) (max +min-ethernet-frame-size+
 				       (+ start 28)))
-    (setf packet (make-array +min-ethernet-frame-size+ :element-type 'muerte::u8)))
+    (setf packet (make-array +min-ethernet-frame-size+
+			     :element-type '(unsigned-byte 8))))
   (setf (aref packet (+ start 0)) (ldb (byte 8 8) hard-type)
 	(aref packet (+ start 1)) (ldb (byte 8 0) hard-type)
 	(aref packet (+ start 2)) (ldb (byte 8 8) prot-type)




From ffjeld at common-lisp.net  Thu Jul 22 00:58:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 17:58:56 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp 
Message-ID: <E1BnRvE-0002AJ-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv8162

Modified Files:
	ne2k.lisp 
Log Message:
Don't use the old vector-u8 stuff.

Date: Wed Jul 21 17:58:56 2004
Author: ffjeld

Index: movitz/losp/x86-pc/ne2k.lisp
diff -u movitz/losp/x86-pc/ne2k.lisp:1.9 movitz/losp/x86-pc/ne2k.lisp:1.10
--- movitz/losp/x86-pc/ne2k.lisp:1.9	Thu Feb 26 03:19:25 2004
+++ movitz/losp/x86-pc/ne2k.lisp	Wed Jul 21 17:58:56 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:16:00 2002
 ;;;;                
-;;;; $Id: ne2k.lisp,v 1.9 2004/02/26 11:19:25 ffjeld Exp $
+;;;; $Id: ne2k.lisp,v 1.10 2004/07/22 00:58:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -96,7 +96,7 @@
 		  :io-base io-base
 		  :asic-io-base (+ io-base #x10))))
     (reset-device ne2000)
-    (let ((mac (make-array 6 :element-type 'muerte::u8)))
+    (let ((mac (make-array 6 :element-type '(unsigned-byte 8))))
       (with-dp8390 (dp8390 io-base)
 	(with-dp8390-dma (dp8390 remote-read 12 0)
 	  (dotimes (i 6)
@@ -113,7 +113,7 @@
 (defun read-from-ne2k-ring (io-base asic-io packet start length ring-start ring-pointer ring-stop)
   "Read from a NE2000 ring buffer into packet, starting at start,
    length number of bytes."
-  (check-type packet vector-u8)
+  (check-type packet (simple-array (unsigned-byte 8) 1))
   (let* ((ring-space (- ring-stop ring-pointer)))
     (if (<= length ring-space)
 	(with-dp8390 (dp8390 io-base)
@@ -133,7 +133,8 @@
   (let ((read-pointer (next-packet device)))
     (when read-pointer
       (let ((asic-io (asic-io-base device))
-	    (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8)))
+	    (packet (or packet (make-array +max-ethernet-frame-size+
+					   :element-type '(unsigned-byte 8))))
 	    (ring-start (ring-start device))
 	    (ring-stop (ring-stop device)))
 	(with-dp8390 (dp8390 (io-base device))
@@ -206,7 +207,7 @@
     t))
 
 (defmethod transmit ((device ne2000) packet &key (start 0) (end (length packet)))
-  (check-type packet vector-u8)
+  (check-type packet (simple-array (unsigned-byte 8) 1))
   (assert (and (evenp start)))
   (with-dp8390 (dp8390 (io-base device))
     (loop while (logbitp ($command-bit transmit)
@@ -229,7 +230,7 @@
 
 #+ignore
 (defun spinning-receive (ne2000
-			 &optional (packet (make-array 1500 :element-type 'muerte::u8))
+			 &optional (packet (make-array 1500 :element-type '(unsigned-byte 8)))
 			 &key (start 0))
   (multiple-value-bind (recovered-packet recovered-packet-length)
       (recover-when-ring-overflow ne2000 packet :start start)




From ffjeld at common-lisp.net  Thu Jul 22 01:00:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:00:47 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BnRx1-0000z0-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Improved eql compiler-macro a bit.

Date: Wed Jul 21 18:00:47 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.31 movitz/losp/muerte/basic-macros.lisp:1.32
--- movitz/losp/muerte/basic-macros.lisp:1.31	Wed Jul 21 15:30:14 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 21 18:00:47 2004
@@ -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.31 2004/07/21 22:30:14 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.32 2004/07/22 01:00:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -439,7 +439,7 @@
    ((and (movitz:movitz-constantp x env)
 	 (not (typep (movitz:movitz-eval x env)
 		     '(and integer (not fixnum)))))
-    `(eq ',x ,y))
+    `(eq ',(movitz:movitz-eval x env) ,y))
    (t `(with-inline-assembly (:returns :boolean-zf=1)
 	 (:compile-two-forms (:eax :ebx) ,x ,y)
 	 (:call-global-pf fast-eql)))))




From ffjeld at common-lisp.net  Thu Jul 22 01:01:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:01:31 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1BnRxj-0005YG-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
minor edit.

Date: Wed Jul 21 18:01:31 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.9 movitz/losp/muerte/conditions.lisp:1.10
--- movitz/losp/muerte/conditions.lisp:1.9	Tue Jul 20 01:54:05 2004
+++ movitz/losp/muerte/conditions.lisp	Wed Jul 21 18:01:31 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.9 2004/07/20 08:54:05 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.10 2004/07/22 01:01:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -105,7 +105,7 @@
     :initarg :datum
     :reader type-error-datum))
   (:report (lambda (c s)
-	     (format s "The object ~S is not of type ~S."
+	     (format s "The object `~S' is not of type ~S."
 		     (type-error-datum c)
 		     (type-error-expected-type c)))))
 




From ffjeld at common-lisp.net  Thu Jul 22 01:02:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:02:15 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp 
Message-ID: <E1BnRyR-0000ky-00@common-lisp.net>

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

Modified Files:
	cons.lisp 
Log Message:
Use :int 61 for failing on typep list.

Date: Wed Jul 21 18:02:15 2004
Author: ffjeld

Index: movitz/losp/muerte/cons.lisp
diff -u movitz/losp/muerte/cons.lisp:1.5 movitz/losp/muerte/cons.lisp:1.6
--- movitz/losp/muerte/cons.lisp:1.5	Thu Jul 15 14:06:51 2004
+++ movitz/losp/muerte/cons.lisp	Wed Jul 21 18:02:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.5 2004/07/15 21:06:51 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.6 2004/07/22 01:02:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,7 +23,7 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax -1) :ebx)
     (:movl (:eax 3) :eax)
     (:ret)))
@@ -33,7 +33,7 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax -1) :eax)
     (:ret)))
 
@@ -43,7 +43,9 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:ebx -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 66)))
     (:movl (:ebx -1) :eax)
     (:ret)))
 
@@ -52,7 +54,7 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax 3) :eax)
     (:ret)))
 
@@ -61,11 +63,11 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax 3) :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax 3) :eax)
     (:ret)))
 
@@ -74,15 +76,15 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program (not-cons) (:int 66)))
+    (:jnz '(:sub-program (not-cons) (:int 61)))
     (:movl (:eax 3) :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program (not-cons) (:int 66)))
+    (:jnz '(:sub-program (not-cons) (:int 61)))
     (:movl (:eax 3) :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program (not-cons) (:int 66)))
+    (:jnz '(:sub-program (not-cons) (:int 61)))
     (:movl (:eax 3) :eax)
     (:ret)))
 
@@ -92,7 +94,9 @@
   (with-inline-assembly (:returns :eax)
     (:leal (:ebx -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 61)))
     (:movl (:ebx 3) :eax)
     (:ret)))
 
@@ -104,7 +108,7 @@
     (:prefetch-nta (:eax))
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax -1) :ebx)
     (:movl (:eax 3) :eax)
     (:ret)))
@@ -115,7 +119,7 @@
     (:prefetch-nta (:eax))
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax -1) :eax)
     (:ret)))
 
@@ -126,7 +130,9 @@
     (:prefetch-nta (:ebx))
     (:leal (:ebx -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 61)))
     (:movl (:ebx -1) :eax)
     (:ret)))
 
@@ -136,7 +142,7 @@
     (:prefetch-nta (:eax))
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program () (:int 61)))
     (:movl (:eax 3) :eax)
     (:prefetch-nta (:eax))
     (:ret)))
@@ -148,7 +154,9 @@
     (:prefetch-nta (:ebx))
     (:leal (:ebx -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 61)))
     (:movl (:ebx 3) :eax)
     (:prefetch-nta (:eax))
     (:ret)))
@@ -159,7 +167,9 @@
     (:compile-form (:result-mode :eax) value)
     (:leal (:ebx -1) :ecx)
     (:testb 7 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 61)))
     (:movl :eax (:ebx -1))))
 
 (defun (setf cdr) (value cell)
@@ -168,7 +178,9 @@
     (:compile-form (:result-mode :eax) value)
     (:leal (:ebx -1) :ecx)
     (:testb 7 :cl)
-    (:jnz '(:sub-program () (:int 66)))
+    (:jnz '(:sub-program ()
+	    (:movl :ebx :eax)
+	    (:int 61)))
     (:movl :eax (:ebx 3))))
 
 




From ffjeld at common-lisp.net  Thu Jul 22 01:02:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:02:22 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1BnRyY-0000v2-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Use :int 61 for failing on typep list.

Date: Wed Jul 21 18:02:22 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.17 movitz/losp/muerte/interrupt.lisp:1.18
--- movitz/losp/muerte/interrupt.lisp:1.17	Wed Jul 21 07:16:15 2004
+++ movitz/losp/muerte/interrupt.lisp	Wed Jul 21 18:02:22 2004
@@ -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.17 2004/07/21 14:16:15 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.18 2004/07/22 01:02:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -274,12 +274,13 @@
 		     $eip
 		     (interrupt-frame-ref :error-code :unsigned-byte32 0 interrupt-frame)
 		     $eax $ebx $ecx))
-	  ((61)
+	  ((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)))
 	   (format *query-io* "Enter a new value: ")
 	   (setf (dereference $eax) (read *query-io*)))
+	  (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))




From ffjeld at common-lisp.net  Thu Jul 22 01:07:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:07:38 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/equalp.lisp 
Message-ID: <E1BnS3e-0007uJ-00@common-lisp.net>

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

Modified Files:
	equalp.lisp 
Log Message:
Minor edit.

Date: Wed Jul 21 18:07:38 2004
Author: ffjeld

Index: movitz/losp/muerte/equalp.lisp
diff -u movitz/losp/muerte/equalp.lisp:1.5 movitz/losp/muerte/equalp.lisp:1.6
--- movitz/losp/muerte/equalp.lisp:1.5	Tue Jun  8 18:16:52 2004
+++ movitz/losp/muerte/equalp.lisp	Wed Jul 21 18:07:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 13 17:09:08 2001
 ;;;;                
-;;;; $Id: equalp.lisp,v 1.5 2004/06/09 01:16:52 ffjeld Exp $
+;;;; $Id: equalp.lisp,v 1.6 2004/07/22 01:07:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,7 +22,7 @@
 (in-package muerte)
 
 (defun eql (x y)
-  (eql x y))
+  (compiler-macro-call eql x y))
 
 (defun equal (x y)
   (typecase x




From ffjeld at common-lisp.net  Thu Jul 22 01:08:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:08:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BnS4I-0000di-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Try to avoid object-equalp going into infinite recursion.

Date: Wed Jul 21 18:08:18 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.29 movitz/losp/muerte/inspect.lisp:1.30
--- movitz/losp/muerte/inspect.lisp:1.29	Wed Jul 21 04:49:48 2004
+++ movitz/losp/muerte/inspect.lisp	Wed Jul 21 18:08:18 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.29 2004/07/21 11:49:48 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.30 2004/07/22 01:08:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -229,12 +229,12 @@
 		  (dotimes (i (funobj-num-constants x) t)
 		    (unless (test funobj-constant-ref i)))))
 	    (symbol
-	     (and (test memref -7 0 :lisp)
-		  (test memref -7 1 :lisp)
-		  (test memref -7 2 :lisp)
-		  (test memref -7 3 :lisp)
-		  (test memref -7 4 :lisp)
-		  (test memref -7 5 :lisp)))
+	     (and ;; (test memref -7 0 :lisp) ; value
+		  (test memref -7 1 :lisp)    ; function-value
+		  ;; (test memref -7 2 :lisp) ; plist
+		  (test memref -7 3 :lisp)    ; name
+		  ;; (test memref -7 4 :lisp) ; package
+		  (test memref -7 5 :lisp))) ; flags
 	    (vector
 	     (and (typep y 'vector)
 		  (test array-element-type)




From ffjeld at common-lisp.net  Thu Jul 22 01:09:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:09:44 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BnS5g-00065J-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Improved array-element-type, make-array, and array typep.

Date: Wed Jul 21 18:09:44 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.39 movitz/losp/muerte/arrays.lisp:1.40
--- movitz/losp/muerte/arrays.lisp:1.39	Wed Jul 21 15:33:55 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul 21 18:09:44 2004
@@ -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.39 2004/07/21 22:33:55 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.40 2004/07/22 01:09:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -60,7 +60,7 @@
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
        'character)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
-       'muerte::u8)
+       '(unsigned-byte 8))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
        '(unsigned-byte 16))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
@@ -737,19 +737,20 @@
                      (car dimensions))
                     (t
                      (error "Multi-dimensional arrays not supported.")))))
-    (cond
-      ;; These should be replaced by subtypep sometime.
-      ((eq element-type 'character)
-       (make-basic-vector%character size fill-pointer initial-element initial-contents))
-      ((member element-type '(bit (unsigned-byte 1)) :test #'equal)
-       (make-basic-vector%bit size fill-pointer initial-element initial-contents))
-      ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (make-basic-vector%u8 size fill-pointer initial-element initial-contents))
-      ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (make-basic-vector%u32 size fill-pointer initial-element initial-contents))
-      ((eq element-type 'code)
-       (make-basic-vector%code size fill-pointer initial-element initial-contents))
-      (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
+    (let ((upgraded-element-type (upgraded-array-element-type element-type)))
+      (cond
+       ;; These should be replaced by subtypep sometime.
+       ((eq upgraded-element-type 'character)
+	(make-basic-vector%character size fill-pointer initial-element initial-contents))
+       ((eq upgraded-element-type 'bit)
+	(make-basic-vector%bit size fill-pointer initial-element initial-contents))
+       ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal)
+	(make-basic-vector%u8 size fill-pointer initial-element initial-contents))
+       ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal)
+	(make-basic-vector%u32 size fill-pointer initial-element initial-contents))
+       ((eq upgraded-element-type 'code)
+	(make-basic-vector%code size fill-pointer initial-element initial-contents))
+       (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))))
 
 (defun vector (&rest objects)
   "=> vector"
@@ -829,8 +830,14 @@
 	   (and (integerp dimension-spec)
 		(= dimension-spec (array-dimensions x)))
 	   (and (listp dimension-spec)
-		(do ((d 0 (1+ d))
+		(do ((array-rank (array-dimensions x))
+		     (d 0 (1+ d))
 		     (q dimension-spec))
-		    ((null q) t)
-		  (unless (= (pop q) (array-dimension x d))
-		    (return nil)))))))
+		    ((null q) (= d array-rank))
+		  (let ((dim (pop q)))
+		    (cond
+		     ((>= d array-rank)
+		      (return nil))
+		     ((eq dim '*))
+		     ((= dim (array-dimension x d)))
+		     (t (return nil)))))))))




From ffjeld at common-lisp.net  Thu Jul 22 01:11:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 21 Jul 2004 18:11:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp 
Message-ID: <E1BnS78-0003BB-00@common-lisp.net>

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

Modified Files:
	packet.lisp 
Log Message:
Some minor tweaks. Seems to run OK.

Date: Wed Jul 21 18:11:14 2004
Author: ffjeld

Index: movitz/losp/tmp/packet.lisp
diff -u movitz/losp/tmp/packet.lisp:1.3 movitz/losp/tmp/packet.lisp:1.4
--- movitz/losp/tmp/packet.lisp:1.3	Wed Jul 21 15:37:06 2004
+++ movitz/losp/tmp/packet.lisp	Wed Jul 21 18:11:14 2004
@@ -171,13 +171,13 @@
 (defvar *encode-bit-offset* 0 "The current accumulator bit-position.")
 
 (defmacro with-buffer-output (() &body body)
-  `(let ((*encode-buffer* (make-array '(0) :element-type 'octet
+  `(let ((*encode-buffer* (make-array '(1514) :element-type 'octet
                                       :adjustable t :fill-pointer 0))
          (*encode-position* 0)
          (*encode-bit-bucket* 0)
          (*encode-bit-offset* 0))
-    , at body
-    (coerce *encode-buffer* 'buffer)))
+     , at body
+     (coerce *encode-buffer* 'buffer)))
 
 (defun encoding-position ()
   (length *encode-buffer*))
@@ -793,8 +793,8 @@
 
 (defun encode-test ()
   "Check that (encode (decode PACKET)) <=> identity."
-  (assert (and (equalp *udp-packet* (encode (decode *udp-packet*)))
-               (equalp *arp-packet* (encode (decode *arp-packet*))))))
+  (assert (not (mismatch *udp-packet* (encode (decode *udp-packet*)))))
+  (assert (not (mismatch *arp-packet* (encode (decode *arp-packet*))))))
 
 (defun bench (n)
   "Show how long it takes to decode and re-encode 10^N UDP packets."




From ffjeld at common-lisp.net  Fri Jul 23 14:36:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 07:36:47 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1Bo1AF-0005nC-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Two fixes: Changed some uses of "unspecified type error" to
not-a-list-type-error, and the rather nasty bug in the compiler-macros
for funcall%3ops that didn't restore the stack-pointer after the call.

Date: Fri Jul 23 07:36:47 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.32 movitz/losp/muerte/basic-macros.lisp:1.33
--- movitz/losp/muerte/basic-macros.lisp:1.32	Wed Jul 21 18:00:47 2004
+++ movitz/losp/muerte/basic-macros.lisp	Fri Jul 23 07:36:47 2004
@@ -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.32 2004/07/22 01:00:47 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.33 2004/07/23 14:36:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -608,13 +608,15 @@
 	 (:compile-form (:result-mode :eax) ,cell)
 	 (:leal (:eax -1) :ecx)
 	 (:testb 7 :cl)
-	 (:jnz '(:sub-program () (:int 66)))
+	 (:jnz '(:sub-program () (:int 61)))
 	 (:movl :edi (:eax -1)))
     `(with-inline-assembly (:returns :eax)
        (:compile-two-forms (:eax :ebx) ,value ,cell)
        (:leal (:ebx -1) :ecx)
        (:testb 7 :cl)
-       (:jnz '(:sub-program () (:int 66)))
+       (:jnz '(:sub-program ()
+	       (:movl :ebx :eax)
+	       (:int 61)))
        (:movl :eax (:ebx -1)))))
 
 (define-compiler-macro (setf cdr) (value cell &environment env)
@@ -624,13 +626,15 @@
 	 (:compile-form (:result-mode :eax) ,cell)
 	 (:leal (:eax -1) :ecx)
 	 (:testb 7 :cl)
-	 (:jnz '(:sub-program () (:int 66)))
+	 (:jnz '(:sub-program () (:int 61)))
 	 (:movl :edi (:eax 3)))
     `(with-inline-assembly (:returns :eax)
        (:compile-two-forms (:eax :ebx) ,value ,cell)
        (:leal (:ebx -1) :ecx)
        (:testb 7 :cl)
-       (:jnz '(:sub-program () (:int 66)))
+       (:jnz '(:sub-program ()
+	       (:movl :ebx :eax)
+	       (:int 61)))
        (:movl :eax (:ebx 3)))))
 
 (define-compiler-macro rplaca (cons object)
@@ -638,7 +642,7 @@
      (:compile-two-forms (:eax :ebx) ,cons ,object)
      (:leal (:eax -1) :ecx)
      (:testb 7 :cl)
-     (:jnz '(:sub-program () (:int 66)))
+     (:jnz '(:sub-program () (:int 61)))
      (:movl :ebx (:eax -1))))
 
 (define-compiler-macro rplacd (cons object)
@@ -646,7 +650,7 @@
      (:compile-two-forms (:eax :ebx) ,cons ,object)
      (:leal (:eax -1) :ecx)
      (:testb 7 :cl)
-     (:jnz '(:sub-program () (:int 66)))
+     (:jnz '(:sub-program () (:int 61)))
      (:movl :ebx (:eax 3))))
 
 (define-compiler-macro endp (x)
@@ -795,7 +799,8 @@
 	   (:jne 'not-funobj)
 	   (:movl :edx :esi)
 	  funobj-ok
-	   (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))))))))
+	   (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op)))
+	   (:leal (:esp 4) :esp))))))
 
 (define-compiler-macro funcall%unsafe%1ops (function arg0)
   `(with-inline-assembly (:returns :multiple-values)
@@ -813,14 +818,9 @@
   `(let ((fn ,function))
      (with-inline-assembly (:returns :multiple-values)
        (:compile-arglist () ,arg0 ,arg1 ,arg2)
-;;;     (:compile-form (:result-mode :push) ,function)
-;;;     (:compile-form (:result-mode :push) ,arg0)
-;;;     (:compile-two-forms (:ebx :ecx) ,arg1 ,arg2)
-;;;     (:popl :eax)
-;;;     (:popl :esi)
-;;;     (:pushl :ecx)
        (:compile-form (:result-mode :esi) fn)
-       (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))))))
+       (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op)))
+       (:leal (:esp 4) :esp))))
 
 (define-compiler-macro funcall%unsafe (function &rest args)
   (case (length args)




From ffjeld at common-lisp.net  Fri Jul 23 15:26:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:26:52 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bo1wi-0007Qb-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Added and improved debugging instrumentation of this GC.

Date: Fri Jul 23 08:26:51 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.30 movitz/losp/los0-gc.lisp:1.31
--- movitz/losp/los0-gc.lisp:1.30	Tue Jul 20 16:47:50 2004
+++ movitz/losp/los0-gc.lisp	Fri Jul 23 08:26:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.30 2004/07/20 23:47:50 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.31 2004/07/23 15:26:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,10 @@
 
 (defvar *gc-quiet* nil)
 (defvar *gc-running* nil)
+(defvar *gc-break* nil)
+(defvar *gc-trigger* nil)
+(defvar *gc-consitency-check* t) 
+
     
 (defun make-space (location size)
   "Make a space vector at a fixed location."
@@ -100,6 +104,39 @@
 	    (:ret))))
     (do-it)))
 
+
+(defun trigger-full-newspace (free-space)
+  "Make it so that there's only free-space words left before newspace is full."
+  (let ((trigger (if (consp *gc-trigger*)
+		     (pop *gc-trigger*)
+		   *gc-trigger*)))
+    (when trigger
+      (macrolet
+	  ((do-it ()
+	     `(with-inline-assembly (:returns :nothing)
+		(:compile-form (:result-mode :eax) (+ free-space trigger))
+		(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+		(:testl ,(logxor #xffffffff
+				 (* #xfff movitz:+movitz-fixnum-factor+))
+			:eax)
+		(:jnz '(:sub-program () (:int 64)))
+		(:addl 4 :eax)
+		(:andl -8 :eax)
+		(:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		       :ecx)
+		(:subl :eax :ecx)
+		(:movl (:edx 2) :ebx)
+		(:movl :ecx (:edx 2))
+		(:addl 8 :ebx)
+	       fill-loop
+		(:movl :edi (:edx :ebx -6))
+		(:addl 4 :ebx)
+		(:cmpl :ebx :ecx)
+		(:ja 'fill-loop)
+		)))
+	(do-it)))))
+  
+
 (define-primitive-function los0-get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
@@ -252,16 +289,18 @@
 	(when *gc-running*
 	  (let ((muerte::*error-no-condition-for-debugger* t))
 	    (error "Recursive GC triggered.")))
-	(let ((*gc-running t))
+	(let ((*gc-running* t))
 	  (unless *gc-quiet*
 	    (format t "~&;; GC.. "))
 	  (stop-and-copy)
-	  (loop				; This is  a nice opportunity to poll the keyboard..
-	    (case (muerte.x86-pc.keyboard:poll-char)
-	      ((#\esc)
-	       (break "Los0 GC keyboard poll."))
-	      ((nil)
-	       (return))))))))
+	  (if *gc-break*
+	      (break "GC break.")
+	    (loop			; This is  a nice opportunity to poll the keyboard..
+	      (case (muerte.x86-pc.keyboard:poll-char)
+		((#\esc)
+		 (break "Los0 GC keyboard poll."))
+		((nil)
+		 (return)))))))))
   (let* ((actual-duo-space (or duo-space
 			       (allocate-duo-space (* kb-size #x100))))
 	 (last-location (object-location (cons 1 2))))
@@ -289,12 +328,12 @@
   (values))
 
 (defun object-in-space-p (space object)
-  (check-type space vector-u32)
+  (check-type space (simple-array (unsigned-byte 32) 1))
   (and (typep object 'pointer)
-       (< (object-location space)
-	  (object-location object)
-	  (+ (object-location space)
-	     (array-dimension space 0)))))
+       (<= (+ 2 (object-location space))
+	   (object-location object)
+	   (+ 1 (object-location space)
+	      (array-dimension space 0)))))
 
 (defun tenure ()
   (install-old-consing)
@@ -359,14 +398,6 @@
 		   (cond
 		    ((not (object-in-space-p oldspace x))
 		     x)
-		    #+ignore ((typep x 'bignum)
-			      (let ((fwi (position (object-location x) *x* :test #'eq)))
-				(if fwi
-				    (muerte::%word-offset (aref *x* (1+ fwi)) 6)
-				  (let ((fw (shallow-copy x)))
-				    (vector-push (object-location x) *x*)
-				    (vector-push (object-location fw) *x*)
-				    fw))))
 		    (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
 			 (if (object-in-space-p newspace forwarded-x)
 			     (progn
@@ -374,8 +405,9 @@
 					   (object-tag x)))
 			       forwarded-x)
 			   (let ((forward-x (shallow-copy x)))
-			     (let ((a *x*))
-			       (when (typep x 'muerte::pointer)
+			     (when (and (typep x 'muerte::pointer)
+					*gc-consitency-check*)
+			       (let ((a *x*))
 				 (vector-push (%object-lispval x) a)
 				 (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
 				 (assert (vector-push (%object-lispval forward-x) a))))
@@ -397,30 +429,32 @@
 	       (setf scan-pointer fresh-pointer))
 
 	;; Consistency check..
-	(let ((a *x*))
-	  ;; First, restore the state of old-space
-	  (do ((i 0 (+ i 3)))
-	      ((>= i (length a)))
-	    (let ((old (%lispval-object (aref a i)))
-		  (old-class (aref a (+ i 1))))
-	      (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
-	  ;; Then, check that each migrated object is equalp to its new self.
-	  (do ((i 0 (+ i 3)))
-	      ((>= i (length a)))
-	    (let ((old (%lispval-object (aref a i)))
-		  (new (%lispval-object (aref a (+ i 2)))))
-	      (unless (and (object-in-space-p newspace new)
-			   (object-in-space-p oldspace old)
-			   (objects-equalp old new))
-		(let ((*old* old)
-		      (*new* new)
-		      (*old-class* (aref a (+ i 1))))
-		  (declare (special *old* *new* *old-class*))
-		  (error "GC consistency check failed:
+	(when *gc-consitency-check*
+	  (let ((a *x*))
+	    ;; First, restore the state of old-space
+	    (do ((i 0 (+ i 3)))
+		((>= i (length a)))
+	      (let ((old (%lispval-object (aref a i)))
+		    (old-class (aref a (+ i 1))))
+		(setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
+	    ;; Then, check that each migrated object is equalp to its new self.
+	    (do ((i 0 (+ i 3)))
+		((>= i (length a)))
+	      (let ((old (%lispval-object (aref a i)))
+		    (new (%lispval-object (aref a (+ i 2)))))
+		(unless (and (object-in-space-p newspace new)
+			     (object-in-space-p oldspace old)
+			     (objects-equalp old new))
+		  (let ((*old* old)
+			(*new* new)
+			(*old-class* (aref a (+ i 1))))
+		    (declare (special *old* *new* *old-class*))
+		    (with-simple-restart (continue "Ignore failed GC consistency check.")
+		      (error "GC consistency check failed:
 old object: ~Z: ~S
 new object: ~Z: ~S
 oldspace: ~Z, newspace: ~Z, i: ~D"
-			 old old new new oldspace newspace i))))))
+			     old old new new oldspace newspace i))))))))
 
 	;; GC completed, oldspace is evacuated.
 	(unless *gc-quiet*
@@ -429,5 +463,6 @@
 	    (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		    old-size new-size (- old-size new-size))))
-	(initialize-space oldspace))))
+	(initialize-space oldspace)
+	(fill oldspace #x3 :start 2))))
   (values))




From ffjeld at common-lisp.net  Fri Jul 23 15:27:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:27:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1Bo1xX-00012m-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Added *map-heap-words-verbose* variable.

Date: Fri Jul 23 08:27:43 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.24 movitz/losp/muerte/scavenge.lisp:1.25
--- movitz/losp/muerte/scavenge.lisp:1.24	Tue Jul 20 07:13:36 2004
+++ movitz/losp/muerte/scavenge.lisp	Fri Jul 23 08:27:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.24 2004/07/20 14:13:36 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.25 2004/07/23 15:27:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,6 +28,7 @@
 ;; etc. involved.
 
 (defvar *scan*)
+(defvar *map-heap-words-verbose* nil)
 
 (defun map-heap-words (function start-location end-location)
   "Map function over each potential pointer word between
@@ -51,13 +52,16 @@
 		  (:shrl 16 :eax)
 		  (:testb ,movitz:+movitz-fixnum-zmask+ :al)
 		  (:jnz '(:sub-program () (:int 63))))))
-    (do ((*scan-last* nil)		; Last scanned object, for debugging.
+    (do ((verbose *map-heap-words-verbose*)
+	 (*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
       (declare (special *scan-last*))
       (let ((*scan* scan)
 	    (x (memref scan 0 0 :lisp)))
 	(declare (special *scan*))
+	(when verbose
+	  (format *terminal-io* "~&MHW scanning at ~S: ~Z" scan x))
 	(cond
 	 ((typep x '(or null fixnum character)))
 	 ((scavenge-typep x :illegal)
@@ -132,6 +136,8 @@
 	    (incf scan delta)))
 	 ((typep x 'pointer)
 	  (let ((new (funcall function x scan)))
+	    (when verbose
+	      (format *terminal-io* " [~Z => ~Z]" x new))
 	    (unless (eq new x)
 	      (setf (memref scan 0 0 :lisp) new))))))))
   (values))
@@ -203,6 +209,8 @@
   "Is stack-frame in a primitive-function?
 If so, return the primitive-function's code-vector."
   (declare (ignore eip-location))
+  ;; XXXX Really we should make comparisons against :call-local-pf
+  ;;      such that we find the active set of local-pf's from the stack-location!
   (let ((return-address (memref stack-location 0 0 :unsigned-byte32))
 	(code-vector (funobj-code-vector funobj)))
     (multiple-value-bind (return-location return-delta)




From ffjeld at common-lisp.net  Fri Jul 23 15:31:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:31:19 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bo211-0006W8-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed a bug in resolve-borrowed-bindings wrt function-bindings:
Sometimes we would generate a forwarding-binding to a
function-binding, but the forwarding-binding-target would be nil
because this function returned nil for function-bindings.

Also, started to use a new strategy with thunks in analyze-bindings.

Date: Fri Jul 23 08:31:19 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.82 movitz/compiler.lisp:1.83
--- movitz/compiler.lisp:1.82	Wed Jul 21 17:27:11 2004
+++ movitz/compiler.lisp	Fri Jul 23 08:31:19 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.82 2004/07/22 00:27:11 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.83 2004/07/23 15:31:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -344,6 +344,7 @@
 	 (resolve-sub-functions toplevel-funobj function-binding-usage)))))))
 
 (defstruct (type-analysis (:type list))
+  (thunks)
   (binding-types)
   (encoded-type
    (multiple-value-list (type-specifier-encode nil))))
@@ -354,12 +355,28 @@
   (when *compiler-do-type-inference*
     (let ((more-binding-references-p nil)
 	  (binding-usage (make-hash-table :test 'eq)))
-      (labels ((type-is-t (type-specifier)
+      (labels ((binding-resolved-p (binding)
+		 (let ((analysis (gethash binding binding-usage)))
+		   (and analysis
+			(null (type-analysis-binding-types analysis))
+			(null (type-analysis-thunks analysis)))))
+	       (binding-resolve (binding)
+		 (if (not (bindingp binding))
+		     binding
+		   (let ((analysis (gethash binding binding-usage)))
+		     (assert (and (and analysis
+				       (null (type-analysis-binding-types analysis))
+				       (null (type-analysis-thunks analysis))))
+			 (binding)
+		       "Can't resolve unresolved binding ~S." binding)
+		     (apply #'encoded-type-decode
+			    (type-analysis-encoded-type analysis)))))
+	       (type-is-t (type-specifier)
 		 (or (eq type-specifier t)
 		     (and (listp type-specifier)
 			  (eq 'or (car type-specifier))
 			  (some #'type-is-t (cdr type-specifier)))))
-	       (analyze-store (binding type)
+	       (analyze-store (binding type thunk thunk-args)
 		 (assert (not (null type)) ()
 		   "store-lexical with empty type.")
 		 (assert (or (typep type 'binding)
@@ -369,6 +386,10 @@
 				     (setf (gethash binding binding-usage)
 				       (make-type-analysis)))))
 		   (cond
+		    (thunk
+		     (assert (some #'bindingp thunk-args))
+		     ;; (warn "got a thunk for ~S" thunk-args)
+		     (push (cons thunk thunk-args) (type-analysis-thunks analysis)))
 		    ((typep binding 'function-argument)
 		     (setf (type-analysis-encoded-type analysis)
 		       (multiple-value-list
@@ -401,10 +422,10 @@
 	       (analyze-code (code)
 		 (dolist (instruction code)
 		   (when (listp instruction)
-		     (multiple-value-bind (store-binding store-type)
+		     (multiple-value-bind (store-binding store-type thunk thunk-args)
 			 (find-written-binding-and-type instruction)
 		       (when store-binding
-			 (analyze-store (binding-target store-binding) store-type)))
+			 (analyze-store (binding-target store-binding) store-type thunk thunk-args)))
 		     (analyze-code (instruction-sub-program instruction)))))
 	       (analyze-funobj (funobj)
 		 (loop for (nil . function-env) in (function-envs funobj)
@@ -419,6 +440,24 @@
 	    doing
 	      (setf more-binding-references-p nil)
 	      (maphash (lambda (binding analysis)
+			 (setf (type-analysis-thunks analysis)
+			   (remove-if (lambda (x)
+					(destructuring-bind (thunk . thunk-args) x
+					  (when (every (lambda (arg)
+							 (or (not (bindingp arg))
+							     (binding-resolved-p arg)))
+						       thunk-args)
+					    (setf more-binding-references-p t)
+					    (setf (type-analysis-encoded-type analysis)
+					      (multiple-value-list
+					       (multiple-value-call
+						   #'encoded-types-or
+						 (values-list
+						  (type-analysis-encoded-type analysis))
+						 (type-specifier-encode
+						  (apply thunk (mapcar #'binding-resolve
+								       thunk-args)))))))))
+				      (type-analysis-thunks analysis)))
 			 (dolist (target-binding (type-analysis-binding-types analysis))
 			   (let* ((target-analysis
 				   (or (gethash target-binding binding-usage)
@@ -451,6 +490,8 @@
 	  (warn "Unable to remove all binding-references during lexical type analysis."))
 	;; 3.
 	(maphash (lambda (binding analysis)
+;;;		   (loop for (nil . thunk-args) in (type-analysis-thunks analysis)
+;;;		       do (warn "Unable to thunk ~S with args ~S." binding thunk-args))
 		   (assert (null (type-analysis-binding-types analysis)) ()
 		     "binding ~S type ~S still refers to ~S"
 		     binding
@@ -516,7 +557,8 @@
 		      (pushnew usage
 			       (getf (sub-function-binding-usage (function-binding-parent binding))
 				     binding))
-		      (pushnew usage (getf function-binding-usage binding))))
+		      (pushnew usage (getf function-binding-usage binding)))
+		    binding)
 		   (t binding))))
 	     (resolve-sub-funobj (funobj sub-funobj)
 	       (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj)))
@@ -2193,8 +2235,10 @@
   (print-unreadable-object (object stream :type t :identity t)
     (when (slot-boundp object 'name)
       (format stream "name: ~S~@[->~S~]~@[ %~A~]"
-	      (binding-name object)
-	      (unless (eq object (binding-target object))
+	      (and (slot-boundp object 'name)
+		   (binding-name object))
+	      (when (and (binding-target object)
+			 (not (eq object (binding-target object))))
 		(binding-name (binding-target object)))
 	      (when (and #+ignore (slot-exists-p object 'store-type)
 			 #+ignore (slot-boundp object 'store-type)
@@ -6107,9 +6151,18 @@
 (define-find-write-binding-and-type :add (instruction)
   (destructuring-bind (term0 term1 destination)
       (cdr instruction)
-    (declare (ignore term0 term1))
     (when (typep destination 'binding)
-      (values destination 'integer))))
+      (assert (and (bindingp term0) (bindingp term1)))
+      (values destination
+	      t
+	      (lambda (type0 type1)
+		(let ((x (multiple-value-call #'encoded-integer-types-add
+			   (type-specifier-encode type0)
+			   (type-specifier-encode type1))))
+		  (warn "thunked: ~S ~S -> ~S" term0 term1)
+		  x))
+	      (list term0 term1)
+	      ))))
 
 (define-find-read-bindings :add (term0 term1 destination)
   (declare (ignore destination))
@@ -6156,10 +6209,12 @@
 		`((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
 			 (:ebp ,(stack-frame-offset loc1)))))))
 	   (t
-;;;	    (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A"
-;;;		    destination loc0 loc1 type0 type1
-;;;		    (type-specifier-singleton type0)
-;;;		    (eq loc1 destination))
+;;;	    (warn "ADD: ~S = ~A/~S + ~A/~S,~%~A ~A"
+;;;		  destination
+;;;		  loc0 term0
+;;;		  loc1 term1
+;;;		  (type-specifier-singleton type0)
+;;;		  (eq loc1 destination))
 ;;;	     (warn "ADDI: ~S" instruction)
 	    (append (cond
 		       ((and (eq :eax loc0) (eq :ebx loc1))




From ffjeld at common-lisp.net  Fri Jul 23 15:32:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:32:35 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bo22F-0001Mi-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Make the initial stack-vector a bit shorted, so we don't get so
extremely long backtraces.

Date: Fri Jul 23 08:32:35 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.49 movitz/image.lisp:1.50
--- movitz/image.lisp:1.49	Wed Jul 21 17:27:17 2004
+++ movitz/image.lisp	Fri Jul 23 08:32:35 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.49 2004/07/22 00:27:17 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.50 2004/07/23 15:32:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -937,7 +937,7 @@
 	  (assert (file-position stream 512) () ; leave room for bootblock.
 	    "Couldn't set file-position for ~W." (pathname stream))
 	  (let* ((stack-vector (make-instance 'movitz-basic-vector
-				 :num-elements #xffff
+				 :num-elements #x1ffe
 				 :fill-pointer 0
 				 :symbolic-data nil
 				 :element-type :u32))
@@ -1311,9 +1311,10 @@
 	 (code-position 0)
 	 (entry-points (map 'list #'identity (subseq code (movitz-vector-fill-pointer code-vector)))))
     (format t "~&;; Movitz Disassembly of ~A:~@[
-;;  Constants: ~A~]
+;;  ~D Constants: ~A~]
 ~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}"
 	    (movitz-print (or (movitz-funobj-name funobj) name))
+	    (length (movitz-funobj-const-list funobj))
 	    (movitz-funobj-const-list funobj)
 	    (loop
 		for pc = 0 then code-position




From ffjeld at common-lisp.net  Fri Jul 23 15:32:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:32:55 -0700
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1Bo22Z-0001p4-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Improved backtrace a bit.

Date: Fri Jul 23 08:32:55 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.10 movitz/procfs-image.lisp:1.11
--- movitz/procfs-image.lisp:1.10	Wed Jul 21 17:28:06 2004
+++ movitz/procfs-image.lisp	Fri Jul 23 08:32:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.10 2004/07/22 00:28:06 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.11 2004/07/23 15:32:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -170,7 +170,18 @@
 		 '(nil :eflags :eip :error-code :exception :ebp nil
 		   :ecx :eax :edx :ebx :esi :edi))))
 
-(defun backtrace (&key reqs)
+(defun debug-get-object (word spartan)
+  (if spartan
+      word
+    (handler-case
+	(let ((object (movitz-word word)))
+	  (typecase object
+	    ((or movitz-funobj movitz-struct movitz-std-instance)
+	     object)
+	    (t (movitz-print object))))
+      (t () (list :unknown-word word)))))
+
+(defun backtrace (&key (reqs t) print-frames print-returns spartan)
   (format t "~&Backtracing from EIP = #x~X: "
 	  (image-register32 *image* :eip))
   ;; (search-image-funobj (image-register32 *image* :eip))
@@ -195,14 +206,17 @@
 				r eax ecx edi eip exception))))
 	     (movitz-symbol
 	      (let ((name (movitz-print movitz-name)))
-		(write-string (symbol-name name))
+		(when print-frames
+		  (format t "~S " stack-frame))
 		(when (string= name 'toplevel-function)
 		  (loop-finish))
-		(format t " (#x~X)" (stack-frame-return-address stack-frame))
 		(when reqs
-		  (format t " req1: ~S, req2: ~S"
-			  (movitz-word (get-word stack-frame -2))
-			  (movitz-word (get-word stack-frame -3))))))
+		  (format t "(~A ~S ~S)"
+			  (symbol-name name)
+			  (debug-get-object (get-word (+ stack-frame -8)) spartan)
+			  (debug-get-object (get-word (+ stack-frame -12)) spartan)))
+		(when print-returns
+		  (format t " (#x~X)" (stack-frame-return-address stack-frame)))))
 	     (t (write (movitz-print movitz-name)))))
       do (format t "~& => "))
   (values))
@@ -276,13 +290,30 @@
 	      (values)))
 
 
+(defvar *previous-image*)
+
 #+allegro
 (top-level:alias ("bochs" 0) (&optional form)
-  (with-bochs-image ()
-    (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid *image*))
+  (let ((*previous-image* *image*))
+    (with-bochs-image ()
+      (let ((image *image*))
+	(with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image))
+	  (if form
+	      (let ((x (eval form)))
+		(format t "~&~W" x)
+		x)
+	    (invoke-debugger "Established Bochs session [pid=~D]. ~S is ~S"
+			     (image-pid image)
+			     '*previous-image*
+			     *previous-image*)))))))
+
+#+allegro
+(top-level:alias ("unbochs" 3) (&optional form)
+  (let ((*image* *previous-image*)
+	(image *image*))
+    (with-simple-restart (continue "Exit this unbochs session")
       (if form
 	  (let ((x (eval form)))
 	    (format t "~&~W" x)
 	    x)
-	(invoke-debugger "Established connection to Bochs [pid=~D]."
-			 (image-pid *image*))))))
+	(invoke-debugger "Established connection to unBochs ~S" image)))))




From ffjeld at common-lisp.net  Fri Jul 23 15:34:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:34:32 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1Bo248-0007tI-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Added support for reading bignums back in from stream-images.

Date: Fri Jul 23 08:34:32 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.30 movitz/storage-types.lisp:1.31
--- movitz/storage-types.lisp:1.30	Wed Jul 21 17:27:22 2004
+++ movitz/storage-types.lisp	Fri Jul 23 08:34:32 2004
@@ -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.30 2004/07/22 00:27:22 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.31 2004/07/23 15:34:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -77,9 +77,6 @@
   :illegal #x13
   :infant-object #x23
 
-  ;; :simple-vector #x20
-  ;; :character-vector 
-  
   :basic-restart #x32
   )
 
@@ -847,10 +844,8 @@
 				   (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj)))))))))
 
 (defmethod print-object ((object movitz-funobj) stream)
-  (if (not (slot-boundp object 'name))
-      (call-next-method)
-    (print-unreadable-object (object stream :type t :identity t)
-      (write (movitz-print (movitz-funobj-name object)) :stream stream))))
+  (print-unreadable-object (object stream :type t :identity t)
+    (write (movitz-print (movitz-funobj-name object)) :stream stream)))
 
 (defmethod sizeof ((obj movitz-funobj))
   (+ (sizeof (find-binary-type 'movitz-funobj))
@@ -1298,3 +1293,13 @@
 (defmethod update-movitz-object ((object movitz-bignum) lisp-object)
   (assert (= (movitz-bignum-value object) lisp-object))
   object)
+
+(defmethod read-binary-record ((type-name (eql 'movitz-bignum)) stream &key)
+  (let* ((header (call-next-method))
+	 (x (loop for i from 0 below (movitz-bignum-length header)
+		summing (ash (read-binary 'u32 stream) (* i 32)))))
+    (setf (movitz-bignum-value header)
+      (ecase (movitz-bignum-sign header)
+	(#x00 x)
+	(#xff (- x))))
+    header))




From ffjeld at common-lisp.net  Fri Jul 23 15:34:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:34:36 -0700
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <E1Bo24C-0008D2-00@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
Added support for reading bignums back in from stream-images.

Date: Fri Jul 23 08:34:36 2004
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.8 movitz/stream-image.lisp:1.9
--- movitz/stream-image.lisp:1.8	Thu Jul  8 11:53:38 2004
+++ movitz/stream-image.lisp	Fri Jul 23 08:34:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Aug 27 14:46:50 2001
 ;;;;                
-;;;; $Id: stream-image.lisp,v 1.8 2004/07/08 18:53:38 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.9 2004/07/23 15:34:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -93,6 +93,8 @@
 			   (read-binary 'movitz-struct (image-stream image)))
 		       (:std-instance
 			(read-binary 'movitz-std-instance (image-stream image)))
+		       (:bignum
+			(read-binary 'movitz-bignum (image-stream image)))
 		       (t (warn "unknown other object: #x~X: ~S code #x~X."
 				word type-tag type-code)
 			  (make-instance 'movitz-fixnum :value (truncate word 4))))))




From ffjeld at common-lisp.net  Fri Jul 23 15:35:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:35:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1Bo24x-00022G-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Made + compiler-macro a bit smarter about constant sub-forms.

Date: Fri Jul 23 08:35:23 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.4 movitz/losp/muerte/arithmetic-macros.lisp:1.5
--- movitz/losp/muerte/arithmetic-macros.lisp:1.4	Tue Jul 20 01:53:50 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Fri Jul 23 08:35:23 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.4 2004/07/20 08:53:50 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.5 2004/07/23 15:35:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -57,7 +57,13 @@
 		  finally (return (if (zerop constant-term)
 				      non-constant-operands
 				    (cons constant-term non-constant-operands))))))
-	 `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands))))))
+	 (cond
+	  ((null operands)
+	   0)
+	  ((not (cdr operands))
+	   (check-type (car operands) integer)
+	   (car operands))
+	  (t `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands))))))))
 
 (define-compiler-macro 1+ (number)
   `(+ 1 ,number))




From ffjeld at common-lisp.net  Fri Jul 23 15:35:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:35:45 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1Bo25J-0002H9-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
Minor edit.

Date: Fri Jul 23 08:35:45 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.10 movitz/losp/muerte/conditions.lisp:1.11
--- movitz/losp/muerte/conditions.lisp:1.10	Wed Jul 21 18:01:31 2004
+++ movitz/losp/muerte/conditions.lisp	Fri Jul 23 08:35:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.10 2004/07/22 01:01:31 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.11 2004/07/23 15:35:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -105,7 +105,8 @@
     :initarg :datum
     :reader type-error-datum))
   (:report (lambda (c s)
-	     (format s "The object `~S' is not of type ~S."
+	     (format s "The object ~Z `~S' is not of type ~S."
+		     (type-error-datum c)
 		     (type-error-datum c)
 		     (type-error-expected-type c)))))
 




From ffjeld at common-lisp.net  Fri Jul 23 15:36:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:36:46 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1Bo26I-0005bs-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Improved copy-control-stack: Take a parameter absolutep which means to
make the stack-frame uplink pointers array indexes rather than locations.

Date: Fri Jul 23 08:36:46 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.30 movitz/losp/muerte/inspect.lisp:1.31
--- movitz/losp/muerte/inspect.lisp:1.30	Wed Jul 21 18:08:18 2004
+++ movitz/losp/muerte/inspect.lisp	Fri Jul 23 08:36:46 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.30 2004/07/22 01:08:18 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.31 2004/07/23 15:36:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -340,8 +340,9 @@
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
 
-(defun copy-control-stack (&optional (stack (%run-time-context-slot 'stack-vector))
-				     (frame (current-stack-frame)))
+(defun copy-control-stack (&key (absolutep)
+				(stack (%run-time-context-slot 'stack-vector))
+				(frame (current-stack-frame)))
   (assert (location-in-object-p stack frame))
   (let* ((stack-start-location (+ 2 (object-location stack)))
 	 (frame-index (- frame stack-start-location))
@@ -357,7 +358,10 @@
 	 (t (let ((uplink-index (- uplink-frame stack-start-location frame-index)))
 	      (assert (< -1 uplink-index (length copy)) ()
 		"Uplink-index outside copy: ~S, i: ~S" uplink-index i)
-	      (let ((x  (+ uplink-index copy-start-location)))
-		(assert (location-in-object-p copy x))
-		(setf (svref%unsafe copy i) x)
-		(setf i uplink-index)))))))))
+	      (setf (svref%unsafe copy i)
+		(if absolutep
+		    uplink-index
+		  (let ((x (+ uplink-index copy-start-location)))
+		    (assert (location-in-object-p copy x))
+		    (setf (svref%unsafe copy i) x))))
+	      (setf i uplink-index))))))))




From ffjeld at common-lisp.net  Fri Jul 23 15:37:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 08:37:17 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1Bo26n-00078p-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Teach typep compiler-macro about basic-restart.

Date: Fri Jul 23 08:37:17 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.31 movitz/losp/muerte/typep.lisp:1.32
--- movitz/losp/muerte/typep.lisp:1.31	Wed Jul 21 15:36:00 2004
+++ movitz/losp/muerte/typep.lisp	Fri Jul 23 08:37:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.31 2004/07/21 22:36:00 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.32 2004/07/23 15:37:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,6 +204,7 @@
 		(tag4 (make-tag-typep :tag4))
 		(tag5 (make-tag-typep :null))
 		(tag6 (make-tag-typep :other))
+		(basic-restart (make-tag-typep :basic-restart))
 		(pointer
 		 (assert (equal (mapcar 'movitz::tag '(:cons :other :symbol))
 				'(1 6 7)))




From ffjeld at common-lisp.net  Fri Jul 23 16:42:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 09:42:39 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1Bo383-0004GH-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Made a slight mistake in the new thunking stuff. This all needs to be
cleaned up.

Date: Fri Jul 23 09:42:39 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.83 movitz/compiler.lisp:1.84
--- movitz/compiler.lisp:1.83	Fri Jul 23 08:31:19 2004
+++ movitz/compiler.lisp	Fri Jul 23 09:42:38 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.83 2004/07/23 15:31:19 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.84 2004/07/23 16:42:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -388,7 +388,6 @@
 		   (cond
 		    (thunk
 		     (assert (some #'bindingp thunk-args))
-		     ;; (warn "got a thunk for ~S" thunk-args)
 		     (push (cons thunk thunk-args) (type-analysis-thunks analysis)))
 		    ((typep binding 'function-argument)
 		     (setf (type-analysis-encoded-type analysis)
@@ -498,7 +497,10 @@
 		     (apply #'encoded-type-decode (type-analysis-encoded-type analysis))
 		     (type-analysis-binding-types analysis))
 		   (setf (binding-store-type binding)
-		     (type-analysis-encoded-type analysis))
+		     (cond
+		      ((not (null (type-analysis-thunks analysis)))
+		       (multiple-value-list (type-specifier-encode t)))
+		      (t (type-analysis-encoded-type analysis))))
 		   #+ignore
 		   (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis))
 		     (warn "Singleton: ~A" binding))




From ffjeld at common-lisp.net  Fri Jul 23 16:44:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 09:44:07 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1Bo39T-0003sX-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Minor edit.

Date: Fri Jul 23 09:44:07 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.31 movitz/losp/los0-gc.lisp:1.32
--- movitz/losp/los0-gc.lisp:1.31	Fri Jul 23 08:26:51 2004
+++ movitz/losp/los0-gc.lisp	Fri Jul 23 09:44:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.31 2004/07/23 15:26:51 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.32 2004/07/23 16:44:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -464,5 +464,5 @@
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		    old-size new-size (- old-size new-size))))
 	(initialize-space oldspace)
-	(fill oldspace #x3 :start 2))))
+	(fill oldspace #x13 :start 2))))
   (values))




From ffjeld at common-lisp.net  Sat Jul 24 01:28:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:28:28 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1BoBKu-0006z2-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added type :unsigned-byte14 for memref.

Date: Fri Jul 23 18:28:28 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.21 movitz/losp/muerte/memref.lisp:1.22
--- movitz/losp/muerte/memref.lisp:1.21	Tue Jul 20 01:54:29 2004
+++ movitz/losp/muerte/memref.lisp	Fri Jul 23 18:28:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.21 2004/07/20 08:54:29 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.22 2004/07/24 01:28:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -112,6 +112,39 @@
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
 			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))))
+		(:unsigned-byte14
+		 (cond
+		  ((and (eq 0 offset) (eq 0 index))
+		   `(with-inline-assembly (:returns :ecx :type (unsigned-byte 14))
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:movzxw (:eax ,(offset-by 2)) :ecx)
+		      (:testb ,movitz:+movitz-fixnum-zmask+ :cl)
+		      (:jnz '(:sub-program () (:int 63)))))
+		  ((eq 0 offset)
+		   (let ((object-var (gensym "memref-object-"))
+			 (index-var (gensym "memref-index-")))
+		     `(let ((,object-var ,object)
+			    (,index-var ,index))
+			(with-inline-assembly (:returns :ecx)
+			  (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
+			  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+			  (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+			  (:testb ,movitz:+movitz-fixnum-zmask+ :cl)
+			  (:jnz '(:sub-program () (:int 63)))))))
+		  (t (let ((object-var (gensym "memref-object-"))
+			   (offset-var (gensym "memref-offset-"))
+			   (index-var (gensym "memref-index-")))
+		       `(let ((,object-var ,object)
+			      (,offset-var ,offset)
+			      (,index-var ,index))
+			  (with-inline-assembly (:returns :ecx)
+			    (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var)
+			    (:leal (:ecx (:ebx 2)) :ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+			    (:testb ,movitz:+movitz-fixnum-shift+ :cl)
+			    (:jnz '(:sub-program () (:int 63)))))))))
 		(:unsigned-byte29+3
 		 ;; Two values: the 29 upper bits as unsigned integer,
 		 ;; and secondly the lower 3 bits as unsigned.
@@ -256,6 +289,7 @@
 (defun memref (object offset index type)
   (ecase type
     (:unsigned-byte8    (memref object offset index :unsigned-byte8))
+    (:unsigned-byte14   (memref object offset index :unsigned-byte14))
     (:unsigned-byte16   (memref object offset index :unsigned-byte16))
     (:unsigned-byte32   (memref object offset index :unsigned-byte32))
     (:character         (memref object offset index :character))




From ffjeld at common-lisp.net  Sat Jul 24 01:29:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:29:06 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1BoBLW-0002qL-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv10918

Modified Files:
	debugger.lisp 
Log Message:
Minor edit.

Date: Fri Jul 23 18:29:06 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.18 movitz/losp/x86-pc/debugger.lisp:1.19
--- movitz/losp/x86-pc/debugger.lisp:1.18	Tue Jul 20 16:53:48 2004
+++ movitz/losp/x86-pc/debugger.lisp	Fri Jul 23 18:29:06 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.18 2004/07/20 23:53:48 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.19 2004/07/24 01:29:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -429,6 +429,7 @@
   (declare (dynamic-extent args))
   (handler-case (apply #'print-stack-frame-arglist args)
     (serious-condition (conditon)
+      (declare (ignore conditon))
       (write-string "#<error printing frame>"))))
 
 (defun backtrace (&key stack




From ffjeld at common-lisp.net  Sat Jul 24 01:30:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:27 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BoBMp-0001U0-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:27 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.50 movitz/image.lisp:1.51
--- movitz/image.lisp:1.50	Fri Jul 23 08:32:35 2004
+++ movitz/image.lisp	Fri Jul 23 18:30:27 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.50 2004/07/23 15:32:35 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.51 2004/07/24 01:30:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1462,7 +1462,7 @@
 	    (unless slot-descriptions
 	      (error "Don't know how to movitz-read struct: ~S" expr))
 	    (let ((movitz-object (make-instance 'movitz-struct
-				   :name (movitz-read (type-of expr))
+				   :class (muerte::movitz-find-class (type-of expr))
 				   :length (length slot-descriptions))))
 	      (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
 	      (setf (slot-value movitz-object 'slot-values)
@@ -1497,7 +1497,8 @@
 		     (movitz-make-upload-form (movitz-symbol-value object)))
 	   (format nil "~:[~;'~]#:~A" quotep (movitz-print object))))
 	(t (check-type package movitz-struct)
-	   (assert (eq (movitz-struct-name package) (movitz-read 'muerte::package-object)))
+	   (assert (eq (movitz-struct-class package)
+		       (muerte::movitz-find-class 'muerte::package-object)))
 	   (let ((package-name (intern (movitz-print (first (movitz-struct-slot-values package))))))
 	     (case package-name
 	       (keyword (format nil ":~A" (movitz-print object)))
@@ -1541,10 +1542,12 @@
   (etypecase expr
     (integer expr)
     (symbol expr)
+    (array expr)
     (cons (mapcar #'movitz-print expr))
     ((or movitz-nil movitz-constant-block) nil)
     (movitz-fixnum
      (movitz-fixnum-value expr))
+    (movitz-std-instance expr)
     (movitz-heap-object
      (or (image-movitz-to-lisp-object *image* expr)
 	 (error "Unknown Movitz object: ~S" expr)))))




From ffjeld at common-lisp.net  Sat Jul 24 01:30:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:32 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BoBMu-0001Yz-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:32 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.31 movitz/special-operators.lisp:1.32
--- movitz/special-operators.lisp:1.31	Tue Jul 20 05:40:07 2004
+++ movitz/special-operators.lisp	Fri Jul 23 18:30:32 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.31 2004/07/20 12:40:07 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.32 2004/07/24 01:30:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -249,7 +249,12 @@
 						       :form nil))
 						   (list exit-label)))))))))))))
 					     
-		  
+(define-special-operator compile-time-find-class (&all all &form form)
+  (destructuring-bind (class-name)
+      (cdr form)
+    (compiler-call #'compile-form-unprotected
+      :form (muerte::movitz-find-class class-name)
+      :forward all)))
 	     
 (define-special-operator make-named-function (&form form &env env)
   (destructuring-bind (name formals declarations docstring body)
@@ -296,7 +301,11 @@
 The valid parameters are~{ ~S~}."
 					    parameter proto-name
 					    (mapcar #'movitz-print (movitz-funobj-const-list funobj-proto)))
-				       do (setf (car (member parameter c)) (movitz-read value)))
+					  (setf (car (member parameter c))
+					    (if (and (consp value)
+						     (eq :movitz-find-class (car value)))
+						(muerte::movitz-find-class (cadr value))
+					      (movitz-read value))))
 				   c))))
       (setf (movitz-funobj-symbolic-name funobj) function-name)
       (setf (movitz-env-named-function function-name) funobj)




From ffjeld at common-lisp.net  Sat Jul 24 01:30:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:40 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BoBN2-0001qc-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:40 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.31 movitz/storage-types.lisp:1.32
--- movitz/storage-types.lisp:1.31	Fri Jul 23 08:34:32 2004
+++ movitz/storage-types.lisp	Fri Jul 23 18:30:40 2004
@@ -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.31 2004/07/23 15:34:32 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.32 2004/07/24 01:30:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -975,15 +975,23 @@
     :initform :defstruct)
    (pad :binary-lisp-type 1)
    (length
-    :binary-lisp-type lu16
+    :binary-type lu16
     :initarg :length
-    :accessor movitz-struct-length)
-   (name
+    :accessor movitz-bignum-length
+    :map-binary-write (lambda (x &optional type)
+			(declare (ignore type))
+			(check-type x (unsigned-byte 14))
+			(* x 4))
+    :map-binary-read (lambda (x &optional type)
+		       (declare (ignore type))
+		       (assert (zerop (mod x 4)))
+		       (truncate x 4)))
+   (class
     :binary-type word
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word
-    :reader movitz-struct-name
-    :initarg :name)
+    :reader movitz-struct-class
+    :initarg :class)
    (slot0 :binary-lisp-type :label)	; the slot values follows here.
    (slot-values
     :initform '()
@@ -1017,7 +1025,7 @@
 
 (defmethod print-object ((object movitz-struct) stream)
   (print-unreadable-object (object stream :type t)
-    (format stream "~S" (slot-value object 'name))))
+    (format stream "~S" (slot-value object 'class))))
 
 ;;;
 
@@ -1072,7 +1080,7 @@
 			       (svref bucket-data (1+ pos)) movitz-value)))
       (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data))
 	     (lh (make-instance 'movitz-struct
-		   :name (movitz-read 'muerte::hash-table)
+		   :class (muerte::movitz-find-class 'muerte::hash-table)
 		   :length 3
 		   :slot-values (list hash-test ; test-function
 				      bucket




From ffjeld at common-lisp.net  Sat Jul 24 01:30:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:44 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1BoBN6-0002K2-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:44 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.10 movitz/losp/muerte/defstruct.lisp:1.11
--- movitz/losp/muerte/defstruct.lisp:1.10	Tue Jul 20 01:54:09 2004
+++ movitz/losp/muerte/defstruct.lisp	Fri Jul 23 18:30:44 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.10 2004/07/20 08:54:09 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,10 +21,10 @@
 
 (defun structure-object-length (object)
   (check-type object structure-object)
-  (movitz-accessor-u16 object movitz-struct length))
+  (memref object -4 0 :unsigned-byte14))
 
 (defun copy-structure (object)
-  (check-type object structure-object)
+  ;; (check-type object structure-object)
   (let* ((length (structure-object-length object))
 	 (copy (malloc-pointer-words (+ 2 length))))
     (setf (memref copy -6 0 :lisp)
@@ -46,8 +46,8 @@
     (:jnz 'fail)
     (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+))
     (:jne 'fail)
-    (:load-constant struct-name :ebx)
-    (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))
+    (:load-constant struct-class :ebx)
+    (:cmpl :ebx (:eax (:offset movitz-struct class)))
     fail))
 
 (defun structure-ref (object slot-number)
@@ -83,8 +83,7 @@
 	    (:jne '(:sub-program (type-error) (:int 66)))
 	    (:cmpb ,(movitz:tag :defstruct) (:eax ,movitz:+other-type-offset+))
 	    (:jne '(:sub-program (type-error) (:int 66)))
-	    (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx)
-	    (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx)
+	    (:movzxw (:eax (:offset movitz-struct length)) :ecx)
 	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
 	    (:jnz '(:sub-program (not-fixnum) (:movl :ebx :eax) (:int 64)))
 	    (:cmpl :ecx :ebx)
@@ -105,8 +104,8 @@
     (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+))
     (:jne '(:sub-program (type-error) (:int 66)))
     (:load-constant struct-name :ebx)
-    (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))
-    (:jne '(:sub-program (type-error) (:int 66)))
+;;;    (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))
+;;;    (:jne '(:sub-program (type-error) (:int 66)))
     ;; type test passed, read slot
     (:load-constant slot-number :ecx)
     (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
@@ -124,8 +123,8 @@
     (:cmpb #.(movitz:tag :defstruct) (:ebx #.movitz:+other-type-offset+))
     (:jne '(:sub-program (type-error) (:int 66)))
     (:load-constant struct-name :ecx)
-    (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))
-    (:jne '(:sub-program (type-error) (:int 66)))
+;;;    (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))
+;;;    (:jne '(:sub-program (type-error) (:int 66)))
     ;; type test passed, write slot
     (:load-constant slot-number :ecx)
     (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
@@ -227,20 +226,27 @@
 		    '(:translate-when :eval ,slot-descriptions :cl :muerte.cl))
 		  (defstruct (:translate-when :eval ,name-and-options :cl :muerte.cl)
 		    . (:translate-when :eval ,slot-names :cl :muerte.cl)))
+		(defclass ,struct-name (structure-object) ()
+			  (:metaclass structure-class)
+			  (:slots ,(loop for (name) in canonical-slot-descriptions
+				       as location upfrom 0
+				       collect (movitz-make-instance 'structure-slot-definition
+								     :name name
+								     :location location))))
 		,@(loop for constructor in (getf options :constructor)
 		      if (and constructor (symbolp constructor))
 		      collect
 			`(defun ,constructor (&key , at key-lambda)
 			   (let ((s (malloc-pointer-words ,(+ 2 (length slot-names)))))
-			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
+			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class)
 					   0 :lisp)
-			       ',struct-name)
+			       (compile-time-find-class ,struct-name))
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type)
 					   0 :unsigned-byte8)
 			       #.(movitz::tag :defstruct))
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length)
 					   0 :unsigned-byte16)
-			       ,(length slot-names))
+			       ,(* movitz:+movitz-fixnum-factor+ (length slot-names)))
 			     ,@(loop for slot-name in slot-names as i upfrom 0 collecting
 				     `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct
 									'movitz::slot0)
@@ -254,15 +260,15 @@
 			       (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list)))
 			  `(defun ,boa-constructor ,boa-lambda-list
 			     (let ((s (malloc-pointer-words ,(+ 2 (length slot-names)))))
-			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
+			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class)
 						      0 :lisp)
-				 ',struct-name)
+				 (compile-time-find-class ,struct-name))
 			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type)
 						      0 :unsigned-byte8)
 				 #.(movitz::tag :defstruct))
 			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length)
 						      0 :unsigned-byte16)
-				 ,(length slot-names))
+				 ,(* movitz:+movitz-fixnum-factor+ (length slot-names)))
 			       ,@(loop for slot-name in slot-names as i upfrom 0
 				     if (member slot-name boa-variables)
 				     collect
@@ -280,7 +286,7 @@
 		      do (error "Don't know how to make class-struct constructor: ~S" constructor))
 		,(when predicate-name
 		   `(defun-by-proto ,predicate-name struct-predicate-prototype
-		      (struct-name ,struct-name)))
+		      (struct-class (:movitz-find-class ,struct-name))))
 		,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions
 		      as accessor-name = (intern (concatenate 'string conc-name (string slot-name))
 						 (movitz::symbol-package-fix-cl struct-name))
@@ -294,13 +300,6 @@
 			`(defun-by-proto ,accessor-name struct-accessor-prototype
 			   (struct-name ,struct-name)
 			   (slot-number ,slot-number)))
-		(defclass ,struct-name (structure-object) ()
-			  (:metaclass structure-class)
-			  (:slots ,(loop for (name) in canonical-slot-descriptions
-				       as location upfrom 0
-				       collect (movitz-make-instance 'structure-slot-definition
-								     :name name
-								     :location location))))
 		',struct-name))
 	    (list
 	     `(progn
@@ -335,6 +334,6 @@
 		',struct-name))
 	    ))))))
 
-(defun structure-object-name (x)
-  (movitz-accessor x movitz-struct name))
+;;;(defun structure-object-name (x)
+;;;  (movitz-accessor x movitz-struct name))
 




From ffjeld at common-lisp.net  Sat Jul 24 01:30:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:49 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BoBNB-0002bZ-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:49 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.16 movitz/losp/muerte/los-closette.lisp:1.17
--- movitz/losp/muerte/los-closette.lisp:1.16	Tue Jul 20 16:51:10 2004
+++ movitz/losp/muerte/los-closette.lisp	Fri Jul 23 18:30:49 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.16 2004/07/20 23:51:10 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.17 2004/07/24 01:30:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1112,9 +1112,9 @@
     (let* ((slots (class-slots class))
 	   (num-slots (length slots))
 	   (struct (malloc-pointer-words (+ 2 num-slots))))
-      (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
+      (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class)
 		    0 :lisp)
-	(class-name class))
+	class)
       (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type)
 		    0 :unsigned-byte8)
 	#.(movitz::tag :defstruct))
@@ -1728,7 +1728,7 @@
       (let ((*never-use-print-object* t)
 	    (*print-length* 4)
 	    (*print-level* 2))
-	(error "Recursive circle:~%:::~S~v{~&::~S~}" args nil *sml-context*))))
+	(error "Recursive circle:~%:::~S~{~&::~S~}" args *bsml-context*))))
   (let ((*bsml-context* (cons args *bsml-context*)))
     (apply 'do-bootstrap-slow-method-lookup args)))
 




From ffjeld at common-lisp.net  Sat Jul 24 01:30:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:30:54 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BoBNG-0002mP-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Changed the implementation of structs a bit: Keep the length encoded
as a fixnum (in 16 bits), and name them by their class metaobject
rather than the symbol name.

Date: Fri Jul 23 18:30:54 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.33 movitz/losp/muerte/primitive-functions.lisp:1.34
--- movitz/losp/muerte/primitive-functions.lisp:1.33	Tue Jul 20 16:51:19 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Fri Jul 23 18:30:54 2004
@@ -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.33 2004/07/20 23:51:19 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.34 2004/07/24 01:30:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -731,7 +731,7 @@
     (function
      (find-class 'function))
     (structure-object
-     (find-class (structure-object-name object)))
+     (structure-object-name object))
     (character
      (find-class 'character))
     (run-time-context




From ffjeld at common-lisp.net  Sat Jul 24 01:32:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 23 Jul 2004 18:32:06 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BoBOQ-00074u-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Minor edit.

Date: Fri Jul 23 18:32:06 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.84 movitz/compiler.lisp:1.85
--- movitz/compiler.lisp:1.84	Fri Jul 23 09:42:38 2004
+++ movitz/compiler.lisp	Fri Jul 23 18:32:06 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.84 2004/07/23 16:42:38 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.85 2004/07/24 01:32:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -6161,7 +6161,7 @@
 		(let ((x (multiple-value-call #'encoded-integer-types-add
 			   (type-specifier-encode type0)
 			   (type-specifier-encode type1))))
-		  (warn "thunked: ~S ~S -> ~S" term0 term1)
+		  ;; (warn "thunked: ~S ~S -> ~S" term0 term1 x)
 		  x))
 	      (list term0 term1)
 	      ))))




From ffjeld at common-lisp.net  Mon Jul 26 21:02:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 26 Jul 2004 14:02:25 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BpCc5-0000kz-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
fix class-of defstructs.

Date: Mon Jul 26 14:02:25 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.34 movitz/losp/muerte/primitive-functions.lisp:1.35
--- movitz/losp/muerte/primitive-functions.lisp:1.34	Fri Jul 23 18:30:54 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Mon Jul 26 14:02:25 2004
@@ -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.34 2004/07/24 01:30:54 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.35 2004/07/26 21:02:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -731,7 +731,7 @@
     (function
      (find-class 'function))
     (structure-object
-     (structure-object-name object))
+     (structure-object-class object))
     (character
      (find-class 'character))
     (run-time-context




From ffjeld at common-lisp.net  Tue Jul 27 09:11:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 02:11:44 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BpNzs-0002FY-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Try to make sure that the segment-descriptor-table is 16-aligned.

Date: Tue Jul 27 02:11:44 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.51 movitz/image.lisp:1.52
--- movitz/image.lisp:1.51	Fri Jul 23 18:30:27 2004
+++ movitz/image.lisp	Tue Jul 27 02:11:44 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.51 2004/07/24 01:30:27 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.52 2004/07/27 09:11:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -408,6 +408,9 @@
 			(declare (ignore x type))
 			(- (bt:slot-offset 'movitz-constant-block 'non-pointers-end)
 			   (bt:slot-offset 'movitz-constant-block 'non-pointers-start))))
+   (bochs-flags
+    :binary-type lu32
+    :initform 0)
    (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START =======
    ;; (align-segment-descriptors :binary-type 4)
    (segment-descriptor-table :binary-type :label)
@@ -446,13 +449,9 @@
    (segment-descriptor-7
     :binary-type segment-descriptor
     :initform (make-segment-descriptor))
-   (bochs-flags
-    :binary-type lu32
-    :initform 0)
    (scratch0				; A non-GC-root scratch register
     :binary-type lu32
     :initform 0)
-
    (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END =======
    
    (atomically-status
@@ -795,6 +794,10 @@
       (ldb (byte 3 0) (image-nil-word *image*))
       (tag :null))
     (setf (image-constant-block *image*) (make-movitz-constant-block))
+    (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-constant-block
+							       'segment-descriptor-table))
+		      16))
+      (warn "Segment descriptor table is not aligned on a 16-byte boundary."))
     (setf (movitz-constant-block-interrupt-descriptor-table (image-constant-block *image*))
       (movitz-read (make-initial-interrupt-descriptors)))
     (setf (image-t-symbol *image*) (movitz-read t))




From ffjeld at common-lisp.net  Tue Jul 27 09:13:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 02:13:36 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BpO1g-00068L-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Added a print-object method for movitz-basic-vectors.

Date: Tue Jul 27 02:13:36 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.32 movitz/storage-types.lisp:1.33
--- movitz/storage-types.lisp:1.32	Fri Jul 23 18:30:40 2004
+++ movitz/storage-types.lisp	Tue Jul 27 02:13:36 2004
@@ -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.32 2004/07/24 01:30:40 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.33 2004/07/27 09:13:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -363,9 +363,19 @@
     :binary-lisp-type :label)		; data follows physically here
    (symbolic-data
     :initarg :symbolic-data
+    :initform nil
     :accessor movitz-vector-symbolic-data))
   (:slot-align type #.+other-type-offset+))
 
+(defmethod print-object ((object movitz-basic-vector) stream)
+  (cond
+   ((eq :character (movitz-vector-element-type object))
+    (print-unreadable-object (object stream :type t :identity nil)
+      (write (map 'string #'identity (movitz-vector-symbolic-data object))
+	     :stream stream))
+    object)
+   (t (call-next-method))))
+    
 (defun vector-type-tag (element-type)
   (dpb (enum-value 'movitz-vector-element-type element-type)
        (byte 8 8)




From ffjeld at common-lisp.net  Tue Jul 27 09:19:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 02:19:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1BpO73-00078Y-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
More defstruct fixes. Structs now have a class slot, not a name
slot. And, let's allow a :superclass option for defstruct.

Date: Tue Jul 27 02:19:09 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.11 movitz/losp/muerte/defstruct.lisp:1.12
--- movitz/losp/muerte/defstruct.lisp:1.11	Fri Jul 23 18:30:44 2004
+++ movitz/losp/muerte/defstruct.lisp	Tue Jul 27 02:19:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.12 2004/07/27 09:19:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,6 +23,9 @@
   (check-type object structure-object)
   (memref object -4 0 :unsigned-byte14))
 
+(defun structure-object-class (x)
+  (memref x -6 1 :lisp))
+
 (defun copy-structure (object)
   ;; (check-type object structure-object)
   (let* ((length (structure-object-length object))
@@ -167,6 +170,7 @@
 	       ((cons symbol (cons * null))
 		(let ((parameter (second option)))
 		  (ecase (car option)
+		    (:superclass (push parameter (getf collector :superclass)))
 		    (:conc-name (push (string (or parameter ""))
 				      (getf collector :conc-name)))
 		    (:constructor (push parameter (getf collector :constructor)))
@@ -194,6 +198,7 @@
 			  (assert (<= 1 (length (getf options ,option)) ,max-values) ()
 			    "Option ~S given too many times." ,option))))
 	  (default (:type 1) 'class-struct)
+	  (default (:superclass 1) 'structure-object)
 	  (default (:named 1) nil)
 	  (default (:conc-name 1)
 	      (concatenate 'string (string struct-name) (string #\-)))
@@ -202,9 +207,15 @@
 	  (default (:predicate 1)
 	      (intern (concatenate 'string (string struct-name) (string '-p)))))
 	(let* ((struct-type (first (getf options :type)))
+	       (superclass (first (getf options :superclass)))
 	       (struct-named (first (getf options :named)))
 	       (conc-name (first (getf options :conc-name)))
 	       (predicate-name (first (getf options :predicate)))
+	       (standard-name-and-options (if (not (consp name-and-options))
+					      name-and-options
+					    (remove :superclass name-and-options
+						    :key (lambda (x)
+							   (when (consp x) (car x))))))
 	       (canonical-slot-descriptions
 		(mapcar #'(lambda (d)
 			    "(<slot-name> <init-form> <type> <read-only-p> <initarg>)"
@@ -224,9 +235,9 @@
 		  (setf (gethash '(:translate-when :eval ,struct-name :cl :muerte.cl)
 				 (movitz::image-struct-slot-descriptions movitz:*image*))
 		    '(:translate-when :eval ,slot-descriptions :cl :muerte.cl))
-		  (defstruct (:translate-when :eval ,name-and-options :cl :muerte.cl)
+		  (defstruct (:translate-when :eval ,standard-name-and-options :cl :muerte.cl)
 		    . (:translate-when :eval ,slot-names :cl :muerte.cl)))
-		(defclass ,struct-name (structure-object) ()
+		(defclass ,struct-name (,superclass) ()
 			  (:metaclass structure-class)
 			  (:slots ,(loop for (name) in canonical-slot-descriptions
 				       as location upfrom 0
@@ -334,6 +345,5 @@
 		',struct-name))
 	    ))))))
 
-;;;(defun structure-object-name (x)
-;;;  (movitz-accessor x movitz-struct name))
+
 




From ffjeld at common-lisp.net  Tue Jul 27 09:19:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 02:19:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BpO78-0007AX-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
More defstruct fixes. Structs now have a class slot, not a name
slot. And, let's allow a :superclass option for defstruct.

Date: Tue Jul 27 02:19:14 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.31 movitz/losp/muerte/inspect.lisp:1.32
--- movitz/losp/muerte/inspect.lisp:1.31	Fri Jul 23 08:36:46 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 27 02:19:14 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.31 2004/07/23 15:36:46 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.32 2004/07/27 09:19:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -245,7 +245,7 @@
 		  (test cdr)))
 	    (structure-object
 	     (and (typep y 'structure-object)
-		  (test structure-object-name)
+		  (test structure-object-class)
 		  (test structure-object-length)
 		  (dotimes (i (structure-object-length x) t)
 		    (unless (test structure-ref i)




From ffjeld at common-lisp.net  Tue Jul 27 09:22:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 02:22:21 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BpOA9-0005Dq-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Tuning of the number and rational types.

Date: Tue Jul 27 02:22:21 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.32 movitz/losp/muerte/typep.lisp:1.33
--- movitz/losp/muerte/typep.lisp:1.32	Fri Jul 23 08:37:17 2004
+++ movitz/losp/muerte/typep.lisp	Tue Jul 27 02:22:21 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.32 2004/07/23 15:37:17 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.33 2004/07/27 09:22:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -179,7 +179,7 @@
 		 (make-other-typep :bignum 0))
 		((negative-bignum)
 		 (make-other-typep :bignum #xff))
-		((integer number rational)
+		((integer)
 		 `(with-inline-assembly-case ()
 		    (do-case (t :boolean-zf=1 :labels (done))
 		      (:compile-form (:result-mode :eax) ,object)
@@ -555,8 +555,11 @@
   (typep x 'bignum))
 
 (define-simple-typep (number numberp) (x)
-  "Currently, only integer numbers are supported."
-  (integerp x))
+  "Currently, only integers and ratios are supported."
+  (or (typep x 'fixnum)
+      (and (typep x 'tag6)
+	   (or (typep x 'bignum)
+	       (ratio-p x)))))
 
 (define-simple-typep (function functionp) (x)
   (typep x 'function))




From ffjeld at common-lisp.net  Tue Jul 27 13:46:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:46:39 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BpSHv-0008OE-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed (setf aref) for u8 and code-vectors.

Date: Tue Jul 27 06:46:39 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.40 movitz/losp/muerte/arrays.lisp:1.41
--- movitz/losp/muerte/arrays.lisp:1.40	Wed Jul 21 18:09:44 2004
+++ movitz/losp/muerte/arrays.lisp	Tue Jul 27 06:46:39 2004
@@ -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.40 2004/07/22 01:09:44 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.41 2004/07/27 13:46:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -367,6 +367,7 @@
 		   ;; u8?
 		   (:cmpl ,(movitz:basic-vector-type-tag :u8) :ecx)
 		   (:jne 'not-u8-vector)
+		  code-vector
 		   (:testl ,(logxor #xffffffff (* #xff movitz:+movitz-fixnum-factor+))
 			   :eax)
 		   (:jne '(:sub-program (not-an-u8)
@@ -376,9 +377,14 @@
 		   (:movl :edx :ecx)
 		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 		   (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
 		   (:jmp 'return)
 
 		  not-u8-vector
+		   ;; Code?
+		   (:cmpl ,(movitz:basic-vector-type-tag :code) :ecx)
+		   (:je 'code-vector)
+		   
 		   ;; u32?
 		   (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
 		   (:jne 'not-u32-vector)
@@ -390,7 +396,7 @@
 		  not-u32-vector
 		   ;; bit?
 		   (:cmpl ,(movitz:basic-vector-type-tag :bit) :ecx)
-		   (:jne 'not-u8-vector)
+		   (:jne 'not-bit-vector)
 		   (:testl ,(logxor #xffffffff (* #x1 movitz:+movitz-fixnum-factor+))
 			   :eax)
 		   (:jne '(:sub-program (not-a-bit)




From ffjeld at common-lisp.net  Tue Jul 27 13:47:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:47:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BpSIP-00020B-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Some more ratio support.

Date: Tue Jul 27 06:47:09 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.82 movitz/losp/muerte/integers.lisp:1.83
--- movitz/losp/muerte/integers.lisp:1.82	Wed Jul 21 15:30:51 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 27 06:47:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.82 2004/07/21 22:30:51 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.83 2004/07/27 13:47:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -681,6 +681,14 @@
 		 (- x (- y)))
 		(((integer * -1) (integer * -1))
 		 (%negatef (+ (- x) (- y)) x y))
+		((ratio t)
+		 (make-rational (+ (* (ratio-numerator x) (denominator y))
+				   (* (numerator y) (ratio-denominator x)))
+				(* (ratio-denominator x) (denominator y))))
+		((integer ratio)
+		 (make-rational (+ (* x (denominator y))
+				   (* (ratio-numerator y) x))
+				(denominator y)))
 		)))
 	(do-it)))
    (t (&rest terms)
@@ -1165,6 +1173,15 @@
 			(i 0 (+ i 29)))
 		       ((>= i length) r)
 		     (incf r (ash (* x (ldb (byte 29 i) y)) i)))))
+		((ratio ratio)
+		 (make-rational (* (ratio-numerator x) (ratio-numerator y))
+				(* (ratio-denominator x) (ratio-denominator x))))
+		((ratio t)
+		 (make-rational (* y (ratio-numerator x))
+				(ratio-denominator x)))
+		((t ratio)
+		 (make-rational (* x (ratio-numerator y))
+				(ratio-denominator y)))
 		((t (integer * -1))
 		 (%negatef (* x (- y)) x y))
 		(((integer * -1) t)




From ffjeld at common-lisp.net  Tue Jul 27 13:50:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:50:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1BpSLJ-0001mv-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Re-wrote software-interrupt as raise-exception.

Date: Tue Jul 27 06:50:08 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.18 movitz/losp/muerte/interrupt.lisp:1.19
--- movitz/losp/muerte/interrupt.lisp:1.18	Wed Jul 21 18:02:22 2004
+++ movitz/losp/muerte/interrupt.lisp	Tue Jul 27 06:50:08 2004
@@ -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.18 2004/07/22 01:02:22 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.19 2004/07/27 13:50:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -376,31 +376,28 @@
   (with-inline-assembly (:returns :nothing)
     (:sti)))
 
-(define-primitive-function primitive-software-interrupt ()
-  "A primitive code-vector that generates software interrupts."
-  (macrolet ((make-software-interrupt-code ()
-	       (cons 'progn
-		     (loop for vector from 0 to 255
-			 collect `(with-inline-assembly (:returns :nothing)
-				    ;; Each code-entry is 2+1+1=4 bytes.
-				    ((2) :int ,vector)
-				    ((1) :ret)
-				    ((1) :nop))))))
-    (make-software-interrupt-code)))
-
-(defun software-interrupt (interrupt-vector &optional (eax 0) (ebx 0))
-  "Generate software-interrupt number <interrupt-vector>."
+(defun raise-exception (exception &optional (eax 0) (ebx 0))
+  "Generate a CPU exception, with those values in EAX and EBX."
   ;; The problem now is that the x86 INT instruction only takes an
   ;; immediate argument.
-  ;; Hence the primitive-function primitive-software-interrupt.
-  (check-type interrupt-vector (unsigned-byte 8))
-  (let ((code-vector (symbol-value 'primitive-software-interrupt)))
-    (check-type code-vector vector)
-    (with-inline-assembly-case ()
-      (do-case (t :nothing)
-	(:compile-two-forms (:ecx :edx) interrupt-vector code-vector)
-	(:leal (:edx :ecx 2) :ecx)
-	(:compile-two-forms (:eax :ebx) eax ebx)
-	(:shrl 2 :eax)
-	(:shrl 2 :ebx)
-	(:call :ecx)))))
+  (check-type exception (unsigned-byte 8))
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:load-lexical (:lexical-binding eax) :eax)
+	    (:load-lexical (:lexical-binding ebx) :ebx)
+	    (:load-lexical (:lexical-binding exception) :ecx)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:jnz 'not-0)
+	    (:int 0)
+	    (:jmp 'done)
+	   not-0
+	    ,@(loop for i from 1 to 255 as label = (gensym (format nil "not-~D" i))
+		  appending
+		    `((:decl :ecx)
+		      (:jnz ',label)
+		      (:int ,i)
+		      ;; (:jmp 'done)
+		      ,label))
+	   done)))
+    (do-it)))




From ffjeld at common-lisp.net  Tue Jul 27 13:53:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:53:34 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BpSOc-0002r2-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Some tweaking of the scope of *gc-running*.

Date: Tue Jul 27 06:53:33 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.32 movitz/losp/los0-gc.lisp:1.33
--- movitz/losp/los0-gc.lisp:1.32	Fri Jul 23 09:44:07 2004
+++ movitz/losp/los0-gc.lisp	Tue Jul 27 06:53:33 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.32 2004/07/23 16:44:07 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.33 2004/07/27 13:53:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -292,15 +292,15 @@
 	(let ((*gc-running* t))
 	  (unless *gc-quiet*
 	    (format t "~&;; GC.. "))
-	  (stop-and-copy)
-	  (if *gc-break*
-	      (break "GC break.")
-	    (loop			; This is  a nice opportunity to poll the keyboard..
-	      (case (muerte.x86-pc.keyboard:poll-char)
-		((#\esc)
-		 (break "Los0 GC keyboard poll."))
-		((nil)
-		 (return)))))))))
+	  (stop-and-copy))
+	(if *gc-break*
+	    (break "GC break.")
+	  (loop				; This is  a nice opportunity to poll the keyboard..
+	    (case (muerte.x86-pc.keyboard:poll-char)
+	      ((#\esc)
+	       (break "Los0 GC keyboard poll."))
+	      ((nil)
+	       (return))))))))
   (let* ((actual-duo-space (or duo-space
 			       (allocate-duo-space (* kb-size #x100))))
 	 (last-location (object-location (cons 1 2))))




From ffjeld at common-lisp.net  Tue Jul 27 13:54:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:54:08 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1BpSPA-0004L5-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
Let's have ratios!

Date: Tue Jul 27 06:54:08 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.11 movitz/losp/muerte/common-lisp.lisp:1.12
--- movitz/losp/muerte/common-lisp.lisp:1.11	Tue Jul 20 16:51:01 2004
+++ movitz/losp/muerte/common-lisp.lisp	Tue Jul 27 06:54:07 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.11 2004/07/20 23:51:01 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.12 2004/07/27 13:54:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -37,6 +37,7 @@
 (require :muerte/los-closette)
 (require :muerte/defstruct)
 (require :muerte/hash-tables)
+(require :muerte/ratios)
 (require :muerte/packages)
 (require :muerte/format)
 (require :muerte/error)




From ffjeld at common-lisp.net  Tue Jul 27 13:54:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 06:54:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp 
Message-ID: <E1BpSPE-0004TO-00@common-lisp.net>

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

Added Files:
	ratios.lisp 
Log Message:
Let's have ratios!

Date: Tue Jul 27 06:54:12 2004
Author: ffjeld





From ffjeld at common-lisp.net  Tue Jul 27 14:43:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 07:43:25 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BpTAr-0002nL-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
More ratio support, in truncate and read.

Date: Tue Jul 27 07:43:25 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.83 movitz/losp/muerte/integers.lisp:1.84
--- movitz/losp/muerte/integers.lisp:1.83	Tue Jul 27 06:47:09 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 27 07:43:25 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.83 2004/07/27 13:47:09 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.84 2004/07/27 14:43:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1200,7 +1200,12 @@
 (defun truncate (number &optional (divisor 1))
   (numargs-case
    (1 (number)
-      (values number 0))
+      (if (not (ratio-p number))
+	  (values number 0)
+	(multiple-value-bind (q r)
+	    (truncate (ratio-numerator number)
+		      (ratio-denominator number))
+	  (values q (make-rational r (ratio-denominator number))))))
    (t (number divisor)
       (number-double-dispatch (number divisor)
 	((t (eql 1))
@@ -1384,7 +1389,10 @@
 (defun / (number &rest denominators)
   (numargs-case
    (1 (x)
-      (make-rational 1 x))
+      (if (not (ratio-p x))
+	  (make-rational 1 x)
+	(make-rational (ratio-denominator x)
+		       (ratio-numerator x))))
    (2 (x y)
       (multiple-value-bind (q r)
 	  (truncate x y)




From ffjeld at common-lisp.net  Tue Jul 27 14:43:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 07:43:30 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <E1BpTAw-00031w-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
More ratio support, in truncate and read.

Date: Tue Jul 27 07:43:30 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.7 movitz/losp/muerte/read.lisp:1.8
--- movitz/losp/muerte/read.lisp:1.7	Wed Jul 21 15:35:15 2004
+++ movitz/losp/muerte/read.lisp	Tue Jul 27 07:43:30 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.7 2004/07/21 22:35:15 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.8 2004/07/27 14:43:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -86,25 +86,41 @@
 (defun simple-read-token (string &key (start 0) (end (length string)))
   (let ((colon-position (and (char= #\: (schar string start)) start))
 	(almost-integer nil))
-    (multiple-value-bind (token-end token-integer)
+    (multiple-value-bind (token-end token-integer token-denominator)
 	(do ((integer (or (digit-char-p (schar string start) *read-base*)
 			  (and (member (schar string start) '(#\- #\+))
 			       (> end (1+ start))
 			       (digit-char-p (schar string (1+ start)) *read-base*)
 			       0)))
+	     (denominator nil)
 	     (i (1+ start) (1+ i)))
 	    ((or (>= i end)
 		 (member (schar string i) +simple-token-terminators+))
-	     (values i (if (and integer (char= #\- (schar string start)))
+	     (values i
+		     (unless (eql 0 denominator)
+		       (if (and integer (char= #\- (schar string start)))
 			   (- integer)
-			 integer)))
+			 integer))
+		     (when (and integer denominator (plusp denominator))
+		       denominator)))
 	  (when (char= #\: (schar string i))
 	    (setf colon-position i))
 	  (setf almost-integer integer)
 	  (when integer
-	    (let ((digit (digit-char-p (schar string i) *read-base*)))
-	      (setf integer (and digit (+ (* integer *read-base*) digit))))))
+	    (if (and (not denominator)
+		     (char= #\/ (schar string i)))
+		(setf denominator 0)
+	      (let ((digit (digit-char-p (schar string i) *read-base*)))
+		(cond
+		 ((and denominator (not digit))
+		  (setf integer nil))
+		 (denominator
+		  (setf denominator (+ (* denominator *read-base*) digit)))
+		 (t (setf integer (and digit (+ (* integer *read-base*) digit)))))))))
       (cond
+       (token-denominator
+	(values (make-rational token-integer token-denominator)
+		token-end))
        (token-integer
 	(values token-integer token-end))
        ((and almost-integer		; check for base 10 <n>. notation.
@@ -134,6 +150,12 @@
 
 
 (defun simple-read-integer (string start end radix)
+  (multiple-value-bind (x token-end)
+      (let ((*read-base* radix))
+	(simple-read-token string :start start :end end))
+    (check-type x number)
+    (values x token-end))
+  #+ignore
   (let ((token-end (do ((i start (1+ i)))
 		       ((>= i end) i)
 		     (when (member (schar string i) +simple-token-terminators+)




From ffjeld at common-lisp.net  Tue Jul 27 15:16:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 08:16:55 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1BpThH-0006Ow-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Added a more space-efficient algorithm for printing integers.

Date: Tue Jul 27 08:16:55 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.13 movitz/losp/muerte/print.lisp:1.14
--- movitz/losp/muerte/print.lisp:1.13	Tue Jul 20 01:54:43 2004
+++ movitz/losp/muerte/print.lisp	Tue Jul 27 08:16:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.13 2004/07/20 08:54:43 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.14 2004/07/27 15:16:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -82,11 +82,11 @@
 	  (write-simple-integer bigit base stream)))
       (write-digit (rem x base) stream))))
 
-(defun write-lowlevel-integer (x stream base comma-char comma-interval mincol padchar sign-char pos)
-  (multiple-value-bind (bigit rem)
+(defun write-integer-lowlevel (x stream base comma-char comma-interval mincol padchar sign-char pos)
+  (multiple-value-bind (remainder digit)
       (truncate x base)
     (cond
-     ((zerop bigit)
+     ((zerop remainder)
       (when mincol
 	(do ((i (+ pos 1 (if sign-char 1 0) (if comma-interval (truncate pos comma-interval) 0))
 		(1+ i)))
@@ -94,9 +94,28 @@
 	  (write-char padchar stream)))
       (when sign-char
 	(write-char sign-char stream)))
-     (t (write-lowlevel-integer bigit stream base comma-char comma-interval
+     (t (write-integer-lowlevel remainder stream base comma-char comma-interval
 				mincol padchar sign-char (1+ pos))))
-    (write-digit rem stream))
+    (write-digit digit stream))
+  (when (and comma-interval (plusp pos) (zerop (rem pos comma-interval)))
+    (write-char comma-char stream))
+  nil)
+
+(defun write-integer-lowlevel-ldb (x stream comma-char comma-interval mincol padchar sign-char pos
+				   digit-length)
+  (let* ((digit (ldb (byte digit-length (* pos digit-length)) x)))
+    (cond
+     ((<= (integer-length x) (* (1+ pos) digit-length))
+      (when mincol
+	(do ((i (+ pos 1 (if sign-char 1 0) (if comma-interval (truncate pos comma-interval) 0))
+		(1+ i)))
+	    ((>= i mincol))
+	  (write-char padchar stream)))
+      (when sign-char
+	(write-char sign-char stream)))
+     (t (write-integer-lowlevel-ldb x stream comma-char comma-interval
+				    mincol padchar sign-char (1+ pos) digit-length)))
+    (write-digit digit stream))
   (when (and comma-interval (plusp pos) (zerop (rem pos comma-interval)))
     (write-char comma-char stream))
   nil)
@@ -120,8 +139,11 @@
        (sign-always
 	(values #\+ x))
        (t (values nil x)))
-    (write-lowlevel-integer print-value stream base comma-char comma-interval
-			    mincol padchar sign-char 0))
+    (if (= 1 (logcount base))
+	(write-integer-lowlevel-ldb print-value stream comma-char comma-interval
+				    mincol padchar sign-char 0 (1- (integer-length base)))
+      (write-integer-lowlevel print-value stream base comma-char comma-interval
+			      mincol padchar sign-char 0)))
   (when (and radix (= 10 base))
     (write-char #\. stream))
   nil)




From ffjeld at common-lisp.net  Tue Jul 27 20:59:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 13:59:16 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BpZ2a-0006k7-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added logcount.

Date: Tue Jul 27 13:59:15 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.84 movitz/losp/muerte/integers.lisp:1.85
--- movitz/losp/muerte/integers.lisp:1.84	Tue Jul 27 07:43:25 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 27 13:59:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.84 2004/07/27 14:43:25 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.85 2004/07/27 20:59:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2077,6 +2077,21 @@
 (defun logtest (integer-1 integer-2)
   "=> generalized-boolean"
   (not (= 0 (logand integer-1 integer-2))))
+
+(defun logcount (integer)
+  (etypecase integer
+    (positive-fixnum
+     (with-inline-assembly (:returns :untagged-fixnum-ecx :type (integer 0 29))
+       (:load-lexical (:lexical-binding integer) :eax)
+       (:xorl :ecx :ecx)
+      count-loop
+       (:shll 1 :eax)
+       (:adcl 0 :ecx)
+       (:testl :eax :eax)
+       (:jnz 'count-loop)))
+    (positive-bignum
+     (bignum-logcount integer))))
+	 
 
 (defun dpb (newbyte bytespec integer)
   (logior (mask-field bytespec (ash newbyte (byte-position bytespec)))




From ffjeld at common-lisp.net  Tue Jul 27 21:30:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 14:30:51 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BpZX9-00067x-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Tweaked floor for ratios, and corrected results for negative inputs.

Date: Tue Jul 27 14:30:51 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.85 movitz/losp/muerte/integers.lisp:1.86
--- movitz/losp/muerte/integers.lisp:1.85	Tue Jul 27 13:59:15 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 27 14:30:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.85 2004/07/27 20:59:15 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.86 2004/07/27 21:30:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2112,10 +2112,12 @@
 (defun minus-if (x y)
   (if (integerp x) (- x y) x))
 
-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)
   (numargs-case
    (1 (u) u)
    (2 (u v)
+      (check-type u integer)
+      (check-type v integer)
       ;; Code borrowed from CMUCL.
       (do ((k 0 (1+ k))
 	   (u (abs u) (truncate u 2))
@@ -2133,26 +2135,32 @@
 	       (setq temp (- u v))
 	       (when (zerop temp)
 		 (return (ash u k))))))))
-   (t (&rest numbers)
-      (declare (dynamic-extent numbers))
-      (do ((gcd (car numbers)
+   (t (&rest integers)
+      (declare (dynamic-extent integers))
+      (do ((gcd (car integers)
 		(gcd gcd (car rest)))
-	   (rest (cdr numbers) (cdr rest)))
+	   (rest (cdr integers) (cdr rest)))
 	  ((null rest) gcd)))))
 
 (defun floor (n &optional (divisor 1))
   "This is floor written in terms of truncate."
   (numargs-case
-   (1 (n) n)
+   (1 (n)
+      (if (not (ratio-p n))
+	  (values n 0)
+	(multiple-value-bind (r q)
+	    (floor (ratio-numerator n) (ratio-denominator n))
+	  (values r (make-rational q (ratio-denominator n))))))
    (2 (n divisor)
       (multiple-value-bind (q r)
 	  (truncate n divisor)
 	(cond
-	 ((<= 0 q)
-	  (values q r))
 	 ((= 0 r)
-	  (values q 0))
-	 (t (values (1- q) (+ r divisor))))))
+	  (values q r))
+	 ((or (and (minusp r) (plusp divisor))
+	      (and (plusp r) (minusp divisor)))
+	  (values (1- q) (+ r divisor)))
+	 (t (values q r)))))
    (t (n &optional (divisor 1))
       (floor n divisor))))
 




From ffjeld at common-lisp.net  Tue Jul 27 22:05:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 27 Jul 2004 15:05:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bpa4Q-0007G5-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Tweaked gcd for zero inputs, and truncate for ratio inputs.

Date: Tue Jul 27 15:05:14 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.86 movitz/losp/muerte/integers.lisp:1.87
--- movitz/losp/muerte/integers.lisp:1.86	Tue Jul 27 14:30:51 2004
+++ movitz/losp/muerte/integers.lisp	Tue Jul 27 15:05:14 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.86 2004/07/27 21:30:51 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.87 2004/07/27 22:05:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1384,6 +1384,14 @@
 	 (multiple-value-bind (q r)
 	     (truncate (- number) (- divisor))
 	   (values q (%negatef r number divisor))))
+	((rational rational)
+	 (multiple-value-bind (q r)
+	     (truncate (* (numerator number)
+			  (denominator divisor))
+		       (* (denominator number)
+			  (numerator divisor)))
+	   (values q (make-rational r (* (denominator number)
+					 (denominator divisor))))))
 	))))
 
 (defun / (number &rest denominators)
@@ -2116,25 +2124,26 @@
   (numargs-case
    (1 (u) u)
    (2 (u v)
-      (check-type u integer)
-      (check-type v integer)
       ;; Code borrowed from CMUCL.
-      (do ((k 0 (1+ k))
-	   (u (abs u) (truncate u 2))
-	   (v (abs v) (truncate v 2)))
-	  ((or (oddp u) (oddp v))
-	   (do ((temp (if (oddp u)
-			  (- v)
-			(truncate u 2))
-		      (truncate temp 2)))
-	       (nil)
-	     (when (oddp temp)
-	       (if (plusp temp)
-		   (setq u temp)
-		 (setq v (- temp)))
-	       (setq temp (- u v))
-	       (when (zerop temp)
-		 (return (ash u k))))))))
+      (cond
+       ((= 0 u) v)
+       ((= 0 v) u)
+       (t (do ((k 0 (1+ k))
+	       (u (abs u) (truncate u 2))
+	       (v (abs v) (truncate v 2)))
+	      ((or (oddp u) (oddp v))
+	       (do ((temp (if (oddp u)
+			      (- v)
+			    (truncate u 2))
+			  (truncate temp 2)))
+		   (nil)
+		 (when (oddp temp)
+		   (if (plusp temp)
+		       (setq u temp)
+		     (setq v (- temp)))
+		   (setq temp (- u v))
+		   (when (zerop temp)
+		     (return (ash u k))))))))))
    (t (&rest integers)
       (declare (dynamic-extent integers))
       (do ((gcd (car integers)




From ffjeld at common-lisp.net  Wed Jul 28 10:00:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:22 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BplEU-000681-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:20 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.85 movitz/compiler.lisp:1.86
--- movitz/compiler.lisp:1.85	Fri Jul 23 18:32:06 2004
+++ movitz/compiler.lisp	Wed Jul 28 03:00:20 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.85 2004/07/24 01:32:06 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.86 2004/07/28 10:00:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -499,6 +499,8 @@
 		   (setf (binding-store-type binding)
 		     (cond
 		      ((not (null (type-analysis-thunks analysis)))
+;;;		       (when (not (rest (type-analysis-thunks analysis)))
+;;;			 (warn "One thunk: ~S for ~S" binding (first (type-analysis-thunks analysis))))
 		       (multiple-value-list (type-specifier-encode t)))
 		      (t (type-analysis-encoded-type analysis))))
 		   #+ignore
@@ -1520,7 +1522,7 @@
 	     (when (instruction-is op :call)
 	       (let ((x (global-constant-operand (second op))))
 		 (flet ((try (name)
-			  (and (eql x (slot-offset 'movitz-constant-block name))
+			  (and (eql x (slot-offset 'movitz-run-time-context name))
 			       name)))
 		   (cond
 		    ((not x) nil)
@@ -3555,7 +3557,7 @@
 		((atom tree)
 		 tree)
 		((eq :edi-offset (car tree))
-		 (check-type (cadr tree) symbol "a Movitz constant-block label")
+		 (check-type (cadr tree) symbol "a Movitz run-time-context label")
 		 (+ (global-constant-offset (cadr tree))
 		    (reduce #'+ (cddr tree))))
 		(t (cons (fix-edi-offset (car tree))




From ffjeld at common-lisp.net  Wed Jul 28 10:00:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:33 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BplEf-0007Qc-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:33 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.52 movitz/image.lisp:1.53
--- movitz/image.lisp:1.52	Tue Jul 27 02:11:44 2004
+++ movitz/image.lisp	Wed Jul 28 03:00:33 2004
@@ -9,14 +9,14 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.52 2004/07/27 09:11:44 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.53 2004/07/28 10:00:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (in-package movitz)
 
-(define-binary-class movitz-constant-block (movitz-heap-object)
-  ((constant-block-start :binary-type :label) ; keep this at the top.
+(define-binary-class movitz-run-time-context (movitz-heap-object)
+  ((run-time-context-start :binary-type :label) ; keep this at the top.
    (type
     :binary-type other-type-byte
     :initform :run-time-context)
@@ -168,7 +168,7 @@
     :initarg :null-cons)
    (null-sym
     :binary-type movitz-nil-symbol
-    :reader movitz-constant-block-null-symbol
+    :reader movitz-run-time-context-null-symbol
     :initarg :null-sym)
    ;; primitive functions global constants
    (dynamic-find-binding
@@ -346,28 +346,28 @@
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word
     :initarg :interrupt-handlers
-    :accessor movitz-constant-block-interrupt-handlers)
+    :accessor movitz-run-time-context-interrupt-handlers)
    (interrupt-descriptor-table
     :binary-type word
-    :accessor movitz-constant-block-interrupt-descriptor-table
+    :accessor movitz-run-time-context-interrupt-descriptor-table
     :initarg :interrupt-descriptor-table
     :map-binary-read-delayed 'movitz-word
     :map-binary-write 'map-idt-to-array)
    (toplevel-funobj
     :binary-type word
     :initform nil
-    :accessor movitz-constant-block-toplevel-funobj
+    :accessor movitz-run-time-context-toplevel-funobj
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word)
    (global-properties
     :binary-type word
     :initform nil
-    :accessor movitz-constant-block-global-properties
+    :accessor movitz-run-time-context-global-properties
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word)
    (copy-funobj
     :binary-type word
-    ;; :accessor movitz-constant-block-copy-funobj
+    ;; :accessor movitz-run-time-context-copy-funobj
     :initform 'muerte::copy-funobj
     :map-binary-write (lambda (name type)
 			(declare (ignore type))
@@ -406,8 +406,8 @@
     :initform nil
     :map-binary-write (lambda (x type)
 			(declare (ignore x type))
-			(- (bt:slot-offset 'movitz-constant-block 'non-pointers-end)
-			   (bt:slot-offset 'movitz-constant-block 'non-pointers-start))))
+			(- (bt:slot-offset 'movitz-run-time-context 'non-pointers-end)
+			   (bt:slot-offset 'movitz-run-time-context 'non-pointers-start))))
    (bochs-flags
     :binary-type lu32
     :initform 0)
@@ -491,7 +491,7 @@
 			      (if (not pf-name)
 				  0
 				(truncate (+ (tag :null)
-					     (bt:slot-offset 'movitz-constant-block
+					     (bt:slot-offset 'movitz-run-time-context
 							     (intern (symbol-name pf-name)
 								     :movitz)))
 					  4)))
@@ -507,16 +507,16 @@
 			  (cons :data (truncate jumper 4))
 			  registers))))
 
-(defmethod movitz-object-offset ((obj movitz-constant-block)) 0)
+(defmethod movitz-object-offset ((obj movitz-run-time-context)) 0)
 
 (defun global-constant-offset (slot-name)
   (check-type slot-name symbol)
   
-  (slot-offset 'movitz-constant-block
+  (slot-offset 'movitz-run-time-context
 	       (intern (symbol-name slot-name) :movitz)))
 
-(defun make-movitz-constant-block ()
-  (make-instance 'movitz-constant-block
+(defun make-movitz-run-time-context ()
+  (make-instance 'movitz-run-time-context
     :t-symbol (movitz-read 't)
     :null-cons *movitz-nil*
     :null-sym (movitz-nil-sym *movitz-nil*)))
@@ -577,8 +577,8 @@
     :accessor image-called-functions)
    (toplevel-funobj
     :accessor image-toplevel-funobj)
-   (constant-block
-    :accessor image-constant-block)
+   (run-time-context
+    :accessor image-run-time-context)
    (load-time-funobjs
     :initform ()
     :accessor image-load-time-funobjs)
@@ -622,7 +622,7 @@
 
 (defun unbound-value ()
   (declare (special *image*))
-  (slot-value (image-constant-block *image*)
+  (slot-value (image-run-time-context *image*)
 	      'unbound-value))
 
 (defun edi-offset ()
@@ -707,10 +707,10 @@
 		 (eq :u8 (movitz-vector-element-type code-vector)))
       (error "Not a code-vector at #x~8,'0X: ~S" address code-vector))
     (format t "~&;; Code vector: #x~X" (movitz-intern code-vector))
-    (loop for pf-name in (binary-record-slot-names 'movitz-constant-block
+    (loop for pf-name in (binary-record-slot-names 'movitz-run-time-context
 						   :match-tags :primitive-function)
 	when (= (movitz-intern-code-vector code-vector)
-		(binary-slot-value (image-constant-block *image*) pf-name))
+		(binary-slot-value (image-run-time-context *image*) pf-name))
 	do (format t "~&;; #x~X matches global primitive-function ~W with offset ~D."
 		   address pf-name
 		   (- address (movitz-intern-code-vector code-vector)))
@@ -785,20 +785,20 @@
 		       (copy-hash-table (function-code-sizes *image*))
 		     (make-hash-table :test #'equal)))))
     (setf (image-nil-word *image*)
-      (1+ (- (slot-offset 'movitz-constant-block 'null-cons)
-	     (slot-offset 'movitz-constant-block 'constant-block-start))))
+      (1+ (- (slot-offset 'movitz-run-time-context 'null-cons)
+	     (slot-offset 'movitz-run-time-context 'run-time-context-start))))
     (format t "~&;; NIL value: #x~X.~%" (image-nil-word *image*))
     (assert (eq :null (extract-tag (image-nil-word *image*))) ()
       "NIL value #x~X has tag ~D, but it must be ~D."
       (image-nil-word *image*)
       (ldb (byte 3 0) (image-nil-word *image*))
       (tag :null))
-    (setf (image-constant-block *image*) (make-movitz-constant-block))
-    (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-constant-block
+    (setf (image-run-time-context *image*) (make-movitz-run-time-context))
+    (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-run-time-context
 							       'segment-descriptor-table))
 		      16))
       (warn "Segment descriptor table is not aligned on a 16-byte boundary."))
-    (setf (movitz-constant-block-interrupt-descriptor-table (image-constant-block *image*))
+    (setf (movitz-run-time-context-interrupt-descriptor-table (image-run-time-context *image*))
       (movitz-read (make-initial-interrupt-descriptors)))
     (setf (image-t-symbol *image*) (movitz-read t))
     ;; (warn "NIL value: #x~X" (image-nil-word *image*))
@@ -840,7 +840,7 @@
   (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*))
     (1+ *bootblock-build*))
   (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler)))
-    (setf (movitz-constant-block-interrupt-handlers (image-constant-block *image*))
+    (setf (movitz-run-time-context-interrupt-handlers (image-run-time-context *image*))
       (movitz-read (make-array 256 :initial-element handler))))
   (let ((load-address (image-start-address *image*)))
     (setf (image-cons-pointer *image*) (- load-address
@@ -852,7 +852,7 @@
 					     :load-address 0
 					     :load-end-address 0
 					     :entry-address 0))
-    (assert (= load-address (+ (image-intern-object *image* (image-constant-block *image*))
+    (assert (= load-address (+ (image-intern-object *image* (image-run-time-context *image*))
 			       (image-ds-segment-base *image*))))
     (when multiboot-p
       (assert (< (+ (image-intern-object *image* (image-multiboot-header *image*))
@@ -866,7 +866,7 @@
       (stable-sort (copy-list (image-load-time-funobjs *image*)) #'> :key #'third))
     (let* ((toplevel-funobj (make-toplevel-funobj *image*)))
       (setf (image-toplevel-funobj *image*) toplevel-funobj
-	    (movitz-constant-block-toplevel-funobj (image-constant-block *image*)) toplevel-funobj)
+	    (movitz-run-time-context-toplevel-funobj (image-run-time-context *image*)) toplevel-funobj)
       (format t "~&;; load-sequence:~%~<~A~>~%" (mapcar #'second (image-load-time-funobjs *image*)))
       (movitz-intern toplevel-funobj)
       (let ((init-code-address (+ (movitz-intern-code-vector (movitz-funobj-code-vector toplevel-funobj))
@@ -884,24 +884,24 @@
 			     function-value)
 			 #+ignore (warn "fv: ~W" (movitz-macro-expander-function function-value)))))
 		 (movitz-environment-function-cells (image-global-environment *image*)))
-	(let ((constant-block (image-constant-block *image*)))
-	  ;; pull in functions in constant-block
-	  (dolist (gcf-name (binary-record-slot-names 'movitz-constant-block :match-tags :global-function))
+	(let ((run-time-context (image-run-time-context *image*)))
+	  ;; pull in functions in run-time-context
+	  (dolist (gcf-name (binary-record-slot-names 'movitz-run-time-context :match-tags :global-function))
 	    (let* ((gcf-movitz-name (movitz-read (intern (symbol-name gcf-name)
 							 ':muerte)))
 		   (gcf-funobj (movitz-symbol-function-value gcf-movitz-name)))
-	      (setf (slot-value constant-block gcf-name) 0)
+	      (setf (slot-value run-time-context gcf-name) 0)
 	      (cond
 	       ((or (not gcf-funobj)
 		    (eq 'muerte::unbound gcf-funobj))
 		(warn "Global constant function ~S is not defined!" gcf-name))
 	       (t (check-type gcf-funobj movitz-funobj)
-		  (setf (slot-value constant-block gcf-name)
+		  (setf (slot-value run-time-context gcf-name)
 		    gcf-funobj)))))
-	  ;; pull in primitive functions in constant-block
-	  (dolist (pf-name (binary-record-slot-names 'movitz-constant-block
+	  ;; pull in primitive functions in run-time-context
+	  (dolist (pf-name (binary-record-slot-names 'movitz-run-time-context
 						     :match-tags :primitive-function))
-	    (setf (slot-value constant-block pf-name)
+	    (setf (slot-value run-time-context pf-name)
 	      (find-primitive-function (intern (symbol-name pf-name) :muerte))))
 	  #+ignore
 	  (loop for k being the hash-keys of (movitz-environment-setf-function-names *movitz-global-environment*)
@@ -924,7 +924,7 @@
 	      do (let ((mname (movitz-read var))
 		       (mvalue (movitz-read (symbol-value var))))
 		   (setf (movitz-symbol-value mname) mvalue)))
-	  (setf (movitz-constant-block-global-properties constant-block)
+	  (setf (movitz-run-time-context-global-properties run-time-context)
 	    (movitz-read (list :packages (make-packages-hash)
 			       :setf-namespace (movitz-environment-setf-function-names
 						*movitz-global-environment*)
@@ -1188,7 +1188,7 @@
 		   (setf (gethash lisp-package (image-read-map-hash *image*))
 		     (movitz-read movitz-package)))
 		 lisp-to-movitz-package)
-	(setf (slot-value (movitz-constant-block-null-symbol (image-constant-block *image*))
+	(setf (slot-value (movitz-run-time-context-null-symbol (image-run-time-context *image*))
 			  'package)
 	  (movitz-read (ensure-package (string :common-lisp) :muerte.common-lisp)))
 	(loop for symbol being the hash-key of (image-oblist *image*)
@@ -1204,10 +1204,10 @@
 	movitz-packages))))
 
 
-(defun constant-block-find-slot (offset)
-  "Return the name of the constant-block slot located at offset."
-  (dolist (slot-name (bt:binary-record-slot-names 'movitz-constant-block))
-    (when (= offset (bt:slot-offset 'movitz-constant-block slot-name))
+(defun run-time-context-find-slot (offset)
+  "Return the name of the run-time-context slot located at offset."
+  (dolist (slot-name (bt:binary-record-slot-names 'movitz-run-time-context))
+    (when (= offset (bt:slot-offset 'movitz-run-time-context slot-name))
       (return slot-name))))
 
 (defun comment-instruction (instruction funobj pc)
@@ -1217,10 +1217,10 @@
 		(eq 'ia-x86::edi (ia-x86::operand-register operand))
 		(not (ia-x86::operand-register2 operand))
 		(= 1 (ia-x86::operand-scale operand))
-		(constant-block-find-slot (ia-x86::operand-offset operand))
+		(run-time-context-find-slot (ia-x86::operand-offset operand))
 		(not (typep instruction 'ia-x86-instr::lea)))
       collect (format nil "<Global slot ~A>" 
-		      (constant-block-find-slot (ia-x86::operand-offset operand)))
+		      (run-time-context-find-slot (ia-x86::operand-offset operand)))
       when (and (typep operand 'ia-x86::operand-indirect-register)
 		(eq 'ia-x86::edi (ia-x86::operand-register operand))
 		(typep instruction 'ia-x86-instr::lea)
@@ -1360,8 +1360,8 @@
 
 (defun movitz-disassemble-primitive (name &optional (*image* *image*))
   (let* ((code-vector (cond
-		       ((slot-exists-p (image-constant-block *image*) name)
-			(slot-value (image-constant-block *image*) name))
+		       ((slot-exists-p (image-run-time-context *image*) name)
+			(slot-value (image-run-time-context *image*) name))
 		       (t (movitz-symbol-value (movitz-read name)))))
 	 (code (map 'vector #'identity
 		    (movitz-vector-symbolic-data code-vector)))
@@ -1547,7 +1547,7 @@
     (symbol expr)
     (array expr)
     (cons (mapcar #'movitz-print expr))
-    ((or movitz-nil movitz-constant-block) nil)
+    ((or movitz-nil movitz-run-time-context) nil)
     (movitz-fixnum
      (movitz-fixnum-value expr))
     (movitz-std-instance expr)




From ffjeld at common-lisp.net  Wed Jul 28 10:00:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:40 -0700
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1BplEm-0007yc-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:40 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.11 movitz/procfs-image.lisp:1.12
--- movitz/procfs-image.lisp:1.11	Fri Jul 23 08:32:55 2004
+++ movitz/procfs-image.lisp	Wed Jul 28 03:00:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.11 2004/07/23 15:32:55 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.12 2004/07/28 10:00:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -109,7 +109,7 @@
     (cons (mapcar #'movitz-print expr))
     ((not movitz-object)
      expr)
-    ((or movitz-nil movitz-constant-block) nil)
+    ((or movitz-nil movitz-run-time-context) nil)
     (movitz-std-instance expr)
     (movitz-symbol
      (intern (movitz-print (movitz-symbol-name expr))))
@@ -242,7 +242,7 @@
 
 
 (defun current-dynamic-context ()
-  (slot-value (image-constant-block *image*) 'dynamic-env))
+  (slot-value (image-run-time-context *image*) 'dynamic-env))
 
 (defun stack-ref-p (pointer)
   (let ((top #xa0000)
@@ -265,7 +265,7 @@
   (stack-ref dynamic-context 4 0 :lisp))
 
 (defun load-global-constant (slot-name)
-  (slot-value (image-constant-block *image*) slot-name))
+  (slot-value (image-run-time-context *image*) slot-name))
 
 (defun image-eq (x y)
   (eql (movitz-intern x) (movitz-intern y)))




From ffjeld at common-lisp.net  Wed Jul 28 10:00:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:45 -0700
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1BplEr-0008RM-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:45 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.32 movitz/special-operators.lisp:1.33
--- movitz/special-operators.lisp:1.32	Fri Jul 23 18:30:32 2004
+++ movitz/special-operators.lisp	Wed Jul 28 03:00:45 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.32 2004/07/24 01:30:32 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.33 2004/07/28 10:00:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -632,7 +632,7 @@
       (cdr form)
     (assert (not argument))
     (compiler-values ()
-      :code `((:call (:edi ,(slot-offset 'movitz-constant-block if-name))))
+      :code `((:call (:edi ,(slot-offset 'movitz-run-time-context if-name))))
       :returns :nothing)))
 
 (define-special-operator inlined-not (&all forward &form form &result-mode result-mode)




From ffjeld at common-lisp.net  Wed Jul 28 10:00:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:50 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BplEw-0000eG-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:50 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.33 movitz/storage-types.lisp:1.34
--- movitz/storage-types.lisp:1.33	Tue Jul 27 02:13:36 2004
+++ movitz/storage-types.lisp	Wed Jul 28 03:00:50 2004
@@ -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.33 2004/07/27 09:13:36 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.34 2004/07/28 10:00:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -621,7 +621,7 @@
   (assert (eq type 'word))
   (cond
    ((eq 'muerte::unbound obj)
-    (binary-slot-value (image-constant-block *image*) 'unbound-function))
+    (binary-slot-value (image-run-time-context *image*) 'unbound-function))
    ((typep obj 'movitz-funobj)
     (movitz-intern obj))
    ((symbolp obj)
@@ -987,7 +987,7 @@
    (length
     :binary-type lu16
     :initarg :length
-    :accessor movitz-bignum-length
+    :accessor movitz-struct-length
     :map-binary-write (lambda (x &optional type)
 			(declare (ignore type))
 			(check-type x (unsigned-byte 14))




From ffjeld at common-lisp.net  Wed Jul 28 10:00:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:00:59 -0700
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <E1BplF5-00010M-00@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:00:59 2004
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.9 movitz/stream-image.lisp:1.10
--- movitz/stream-image.lisp:1.9	Fri Jul 23 08:34:36 2004
+++ movitz/stream-image.lisp	Wed Jul 28 03:00:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Aug 27 14:46:50 2001
 ;;;;                
-;;;; $Id: stream-image.lisp,v 1.9 2004/07/23 15:34:36 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.10 2004/07/28 10:00:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -51,7 +51,7 @@
       (value)
     "Unable to set memory-stream's file-position to #x~X." value))
 
-(defmethod image-constant-block ((image stream-image))
+(defmethod image-run-time-context ((image stream-image))
   (movitz-word (image-register32 image :edi)))
 
 (defmethod movitz-word-by-image ((image stream-image) word)
@@ -65,11 +65,11 @@
 		   (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word))))
 		  (:null
 		   #+ignore
-		   (assert (= (- word (tag :null)) (image-constant-block-address image)) (word)
+		   (assert (= (- word (tag :null)) (image-run-time-context-address image)) (word)
 		     "The word #x~8,'0X has NIL tag but isn't NIL." word)
 		   (setf (image-stream-position image) 0 #+ignore (- word (tag :null)))
-		   (let ((object (read-binary 'movitz-constant-block (image-stream image))))
-		     (setf (movitz-heap-object-word (movitz-constant-block-null-symbol object))
+		   (let ((object (read-binary 'movitz-run-time-context (image-stream image))))
+		     (setf (movitz-heap-object-word (movitz-run-time-context-null-symbol object))
 		       word)
 		     object))
 		  (:symbol




From ffjeld at common-lisp.net  Wed Jul 28 10:01:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:01:07 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BplFD-0001iG-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:01:06 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.32 movitz/losp/muerte/inspect.lisp:1.33
--- movitz/losp/muerte/inspect.lisp:1.32	Tue Jul 27 02:19:14 2004
+++ movitz/losp/muerte/inspect.lisp	Wed Jul 28 03:01:06 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.32 2004/07/27 09:19:14 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.33 2004/07/28 10:01:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -303,7 +303,7 @@
       (run-time-context
        (<= object-location
 	   location
-	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-constant-block))))
+	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-run-time-context))))
       (std-instance
        (<= object-location
 	   location




From ffjeld at common-lisp.net  Wed Jul 28 10:01:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:01:12 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BplFI-000204-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:01:11 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.17 movitz/losp/muerte/los-closette.lisp:1.18
--- movitz/losp/muerte/los-closette.lisp:1.17	Fri Jul 23 18:30:49 2004
+++ movitz/losp/muerte/los-closette.lisp	Wed Jul 28 03:01:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.17 2004/07/24 01:30:49 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.18 2004/07/28 10:01:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -993,10 +993,10 @@
 (defclass run-time-context (t)
   ()
   (:metaclass built-in-class)
-  (:size #.(bt:sizeof 'movitz::movitz-constant-block))
-  (:slot-map #.(movitz::slot-map 'movitz::movitz-constant-block
-			       (cl:+ (bt:slot-offset 'movitz::movitz-constant-block
-						     'movitz::constant-block-start)
+  (:size #.(bt:sizeof 'movitz::movitz-run-time-context))
+  (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context
+			       (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context
+						     'movitz::run-time-context-start)
 				     0))))
 
 (defclass stream () ())




From ffjeld at common-lisp.net  Wed Jul 28 10:01:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:01:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1BplFO-0002HT-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:01:16 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.16 movitz/losp/muerte/more-macros.lisp:1.17
--- movitz/losp/muerte/more-macros.lisp:1.16	Tue Jul 20 16:51:15 2004
+++ movitz/losp/muerte/more-macros.lisp	Wed Jul 28 03:01:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.16 2004/07/20 23:51:15 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.17 2004/07/28 10:01:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -328,7 +328,8 @@
 		(equal context '(current-run-time-context))))
       form
     (let ((slot-name (movitz::eval-form slot-name env)))
-      (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz))
+      (ecase (bt:binary-slot-type 'movitz::movitz-run-time-context
+				  (intern (symbol-name slot-name) :movitz))
 	(movitz::word
 	 `(with-inline-assembly (:returns :eax)
 	    (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax))))




From ffjeld at common-lisp.net  Wed Jul 28 10:01:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 03:01:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1BplFT-0002PA-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Change the name "constant-block" to "run-time-context" so as to be
consistent. "Run-time-context" is the name that's I've been using in
newer documentation and code.

Date: Wed Jul 28 03:01:23 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.10 movitz/losp/muerte/run-time-context.lisp:1.11
--- movitz/losp/muerte/run-time-context.lisp:1.10	Tue Jul 20 01:54:48 2004
+++ movitz/losp/muerte/run-time-context.lisp	Wed Jul 28 03:01:23 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.10 2004/07/20 08:54:48 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.11 2004/07/28 10:01:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,7 +48,7 @@
 		(equal context '(current-run-time-context))))
       form
     (let ((slot-name (movitz:movitz-eval slot-name env)))
-      (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz))
+      (ecase (bt:binary-slot-type 'movitz::movitz-run-time-context (intern (symbol-name slot-name) :movitz))
 	(movitz:word
 	 `(with-inline-assembly (:returns :eax)
 	    (:compile-form (:result-mode :eax) ,value)
@@ -114,8 +114,8 @@
 (defun clone-run-time-context (&key (parent (current-run-time-context))
 				    (name :anonymous))
   (check-type parent run-time-context)
-  (let ((context (malloc-pointer-words #.(cl:truncate (bt:sizeof 'movitz::movitz-constant-block) 4))))
-    (memcopy context parent -6 0 0 #.(bt:sizeof 'movitz::movitz-constant-block)
+  (let ((context (malloc-pointer-words #.(cl:truncate (bt:sizeof 'movitz::movitz-run-time-context) 4))))
+    (memcopy context parent -6 0 0 #.(bt:sizeof 'movitz::movitz-run-time-context)
 	     :unsigned-byte8)
     (setf (%run-time-context-slot 'name context) name
 	  (%run-time-context-slot 'self context) context)




From ffjeld at common-lisp.net  Wed Jul 28 12:30:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 05:30:35 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BpnZr-0004zW-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
In the deftype expander, try to be a bit more clever about when to
avoid (cl:deftype cl:whatever ..). The previous detection code
apparently didn't work under sbcl or cmucl.

Date: Wed Jul 28 05:30:35 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.33 movitz/losp/muerte/typep.lisp:1.34
--- movitz/losp/muerte/typep.lisp:1.33	Tue Jul 27 02:22:21 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 28 05:30:34 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.33 2004/07/27 09:22:21 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.34 2004/07/28 12:30:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -429,7 +429,7 @@
   (let ((fname (intern (format nil "~A-~A" 'deftype name))))
     `(progn
        (eval-when (:compile-toplevel)
-	 (unless (eq (symbol-package ',name) (find-package :common-lisp))
+	 (unless (eq (symbol-package (car ',form)) (find-package :common-lisp))
 	   ,form)
 	 (setf (gethash (translate-program ',name :cl :muerte.cl)
 			*compiler-derived-typespecs*)




From ffjeld at common-lisp.net  Wed Jul 28 14:15:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 07:15:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1BppDC-0005Nw-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
The repl package was renamed, so the init defpackage form needs
updating too. The other changes to this file is just my messing around
with testing various bits and pieces.

Date: Wed Jul 28 07:15:17 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.19 movitz/losp/los0.lisp:1.20
--- movitz/losp/los0.lisp:1.19	Mon Jul 12 19:39:13 2004
+++ movitz/losp/los0.lisp	Wed Jul 28 07:15:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.19 2004/07/13 02:39:13 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.20 2004/07/28 14:15:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,17 +28,21 @@
 (require :lib/repl)
 
 (defpackage muerte.init
-  (:use muerte.cl muerte muerte.lib
-	muerte.x86-pc
-	muerte.readline
-	muerte.toplevel
-	muerte.ethernet
-	muerte.ip6
-	muerte.ip4
-	muerte.mop
+  (:nicknames #:los0)
+  (:use #:common-lisp
+	#:muerte
+	#:muerte.lib
+	#:muerte.x86-pc
+	#:repl
+	#:muerte.readline
+	#:muerte.toplevel
+	#:muerte.ethernet
+	#:muerte.ip6
+	#:muerte.ip4
+	#:muerte.mop
 	#+ignore muerte.x86-pc.serial))
 
-(require :los0-gc)
+(require :los0-gc)			; Must come after defpackage.
 
 (in-package muerte.init)
 
@@ -657,7 +661,7 @@
       (loop while (= s0 (rtc-register :second)))
       (multiple-value-bind (c1-lo c1-hi)
 	  (read-time-stamp-counter)
-	(+ (ash (- c1-hi c0-hi) 20)
+	(+ (ash (- c1-hi c0-hi) 19)
 	   (ash (+ 512 (- c1-lo c0-lo)) -10))))))
 
 (defun report-cpu-frequency ()
@@ -666,6 +670,13 @@
     (format t "~&CPU frequency: ~D.~2,'0D MHz.~%" mhz (round khz 10)))
   (values))
 
+(defvar *a* #(#x1 #x2 #x3 #x4 #x5 #x6 #x7 #x8))
+(defvar *b* #(#x5 #xa #xf #x14 #x19 #x1e #x23 #x28 #x1400 #x1e00 #x2800 #x3200
+	      #x3c00 #x4600 #x5000 #xa00 #x50 #x64 #x78 #x8c #xa0 #x14 #x28 #x3c
+	      #xc800 #xf001 #x1801 #x4000 #x2800 #x5000 #x7800 #xa000 #x230 #x280
+	      #x50 #xa0 #xf0 #x140 #x190 #x1e0 #x0 #xa001 #x4001 #xe002 #x8003
+	      #x2003 #xc004 #x6005 #x280 #x3c0 #x500 #x640))
+
 (defvar *cpu-frequency-mhz*)
 
 (defun init-nano-sleep ()
@@ -685,6 +696,10 @@
 
 ;;;;;
 
+(defvar div #xa65feaab511c61e33df38fdddaf03b59b6f25e1fa4de57e5cf00ae478a855dda4f3638d38bb00ac4af7d8414c3fb36e04fbdf3d3166712d43b421bfa757e85694ad27c48f396d03c8bce8da58db5b82039f35dcf857235c2f1c73b2226a361429190dcb5b6cd0edfb0ff6933900b02cecc0ce69274d8dae7c694804318d6d6b9)
+
+(defvar guess #x1dc19f99401de22d476c89943491fc187b80bcfa8293ec1cf69c1a81352f047e894e262d24116c82ad0be241c6c6216cab9b66d64417d43bf433db10114c0)
+
 ;;;;;;;;;;;;;;; CL
 
 (defun install-internal-time (&optional (minimum-frequency 100))
@@ -753,7 +768,7 @@
 
 (define-toplevel-command :bt (&rest args)
   (declare (dynamic-extent args))
-  (apply #'backtrace args))
+  (apply #'backtrace (mapcar #'eval args)))
 
 (define-toplevel-command :cpu-reset ()
   (when (y-or-n-p "Really reset CPU?")
@@ -782,7 +797,7 @@
 
 (define-toplevel-command :z (&optional x-list)
   (flet ((do-print (x)
-	   (format t "~&~Z => ~S" x x)
+	   (format t "~&~Z" x)
 	   x))
     (if x-list
 	(do-print (eval x-list))
@@ -959,6 +974,9 @@
       (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
 	(read-eval-print)))))
 
+(defun ub (x)
+  `(hello world ,x or . what))
+
 (defun random (limit)
   (etypecase limit
     (fixnum
@@ -968,27 +986,57 @@
        (dotimes (i (1- (muerte::%bignum-bigits x)))
 	 (setf (memref x 2 i :unsigned-byte32)
 	   (muerte::read-time-stamp-counter)))
-       (setf x (muerte::%bignum-canonicalize x))
+       (setf x (muerte::bignum-canonicalize x))
        (loop while (>= x limit)
 	   do (setf x (truncate x 2)))
        x))))
 
+(define-primitive-function test-irq-pf ()
+  ""
+  (with-inline-assembly (:returns :nothing)
+    (:int 113)
+    (:ret)))
+
+(defun test-irq (&optional eax ebx ecx edx)
+  (setf (memref nil #x7f 20 :code-vector) (symbol-value 'test-irq-pf))
+  (multiple-value-bind (p1 p2)
+      (with-inline-assembly (:returns :multiple-values)
+	(:load-lexical (:lexical-binding eax) :eax)
+	(:load-lexical (:lexical-binding ebx) :ebx)
+	(:load-lexical (:lexical-binding ecx) :ecx)
+	(:load-lexical (:lexical-binding edx) :edx)
+	(:pushl :eax)
+	(:pushl :ebx)
+	(:jecxz 'dont-call)
+	(:globally (:call (:edi (:edi-offset values) 80)))
+       dont-call
+	(:store-lexical (:lexical-binding eax) :eax :type t)
+	(:store-lexical (:lexical-binding ebx) :ebx :type t)
+	(:store-lexical (:lexical-binding ecx) :ecx :type t)
+	(:store-lexical (:lexical-binding edx) :edx :type t)
+	(:popl :ebx)
+	(:popl :eax)
+	(:movl 2 :ecx)
+	(:stc))
+    (values eax ebx ecx edx p1 p2)))
+
 (defun genesis ()
-  #+ignore
   (let ((extended-memsize 0))
     ;;  Find out how much extended memory we have 
     (setf (io-port #x70 :unsigned-byte8) #x18)
     (setf extended-memsize (* 256 (io-port #x71 :unsigned-byte8)))
     (setf (io-port #x70 :unsigned-byte8) #x17)
     (incf extended-memsize (io-port #x71 :unsigned-byte8))
-    (format t "Extended memory: ~D KB" extended-memsize))
+    (format t "Extended memory: ~D KB~%" extended-memsize)
 
-  (idt-init)
-  (install-los0-consing)
+    (idt-init)
+    (install-los0-consing :kb-size 50)
+    #+ignore
+    (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2))))
   
   (setf *debugger-function* #'los0-debugger)
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
-	(*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
+	#+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
 	#+ignore (*debugger-function* #'los0-debugger)
 	(*package* nil))




From ffjeld at common-lisp.net  Wed Jul 28 14:23:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 07:23:37 -0700
Subject: [movitz-cvs] CVS update: movitz/multiboot.lisp 
Message-ID: <E1BppLF-0005Dc-00@common-lisp.net>

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

Modified Files:
	multiboot.lisp 
Log Message:
Patch from Eric Marsden.

Date: Wed Jul 28 07:23:37 2004
Author: ffjeld

Index: movitz/multiboot.lisp
diff -u movitz/multiboot.lisp:1.4 movitz/multiboot.lisp:1.5
--- movitz/multiboot.lisp:1.4	Thu Mar 25 17:42:45 2004
+++ movitz/multiboot.lisp	Wed Jul 28 07:23:37 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jun 12 12:14:12 2002
 ;;;;                
-;;;; $Id: multiboot.lisp,v 1.4 2004/03/26 01:42:45 ffjeld Exp $
+;;;; $Id: multiboot.lisp,v 1.5 2004/07/28 14:23:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,7 +43,7 @@
     :binary-type lu32
     :initform 0
     :map-binary-write (lambda (x type)
-			(declare (ignore x y))
+			(declare (ignore x type))
 			(- (sizeof 'multiboot-header) 8)))
    (magic
     :accessor magic




From ffjeld at common-lisp.net  Wed Jul 28 14:50:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 07:50:26 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BpplC-0003Tv-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
My previous fix in the deftype expander was flawed: We need to check
the package of the second element of the form (the type-name), not the
first (the operator, i.e. deftype).

Also, on emarsden's suggestion, I added some with-standard-io-syntax
wrappers around some symbol-name generators, just for consistency.

Date: Wed Jul 28 07:50:26 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.34 movitz/losp/muerte/typep.lisp:1.35
--- movitz/losp/muerte/typep.lisp:1.34	Wed Jul 28 05:30:34 2004
+++ movitz/losp/muerte/typep.lisp	Wed Jul 28 07:50:26 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.34 2004/07/28 12:30:34 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.35 2004/07/28 14:50:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -406,7 +406,8 @@
 	    form)))))
 
 (defmacro define-typep (tname lambda &body body)
-  (let ((fname (format nil "~A-~A" 'typep tname)))
+  (let ((fname (with-standard-io-syntax
+		 (format nil "~A-~A" 'typep tname))))
     `(progn
        (eval-when (:compile-toplevel)
 	 (setf (gethash (intern ,(symbol-name tname))
@@ -426,10 +427,11 @@
 	   (defun ,fname ,lambda , at body)))))
 
 (defmacro deftype (&whole form name lambda &body body)
-  (let ((fname (intern (format nil "~A-~A" 'deftype name))))
+  (let ((fname (intern (with-standard-io-syntax
+			 (format nil "~A-~A" 'deftype name)))))
     `(progn
        (eval-when (:compile-toplevel)
-	 (unless (eq (symbol-package (car ',form)) (find-package :common-lisp))
+	 (unless (eq (symbol-package (cadr ',form)) (find-package :common-lisp))
 	   ,form)
 	 (setf (gethash (translate-program ',name :cl :muerte.cl)
 			*compiler-derived-typespecs*)




From ffjeld at common-lisp.net  Thu Jul 29 00:01:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:01:00 -0700
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1BpyM0-000106-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Minor tweaks.

Date: Wed Jul 28 17:00:59 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.12 movitz/procfs-image.lisp:1.13
--- movitz/procfs-image.lisp:1.12	Wed Jul 28 03:00:40 2004
+++ movitz/procfs-image.lisp	Wed Jul 28 17:00:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.12 2004/07/28 10:00:40 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.13 2004/07/29 00:00:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -179,7 +179,7 @@
 	    ((or movitz-funobj movitz-struct movitz-std-instance)
 	     object)
 	    (t (movitz-print object))))
-      (t () (list :unknown-word word)))))
+      (t (c) (list :word-error word c)))))
 
 (defun backtrace (&key (reqs t) print-frames print-returns spartan)
   (format t "~&Backtracing from EIP = #x~X: "
@@ -233,7 +233,7 @@
   (unless (zerop (ldb (byte 2 0) address))
     (warn "Non-aligned address to GET-WORD: #x~8,'0X." address))
   (setf (image-stream-position *image* physicalp) address)
-  (read-binary 'word (image-stream *image*)))
+  (values (read-binary 'word (image-stream *image*))))
 
 (defun do-stack-frame (frame-address count)
   (warn "Frame ~D: #x~8,'0X" count frame-address)




From ffjeld at common-lisp.net  Thu Jul 29 00:12:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:12:49 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <E1BpyXR-0005WE-00@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:12:49 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.18 movitz/compiler-types.lisp:1.19
--- movitz/compiler-types.lisp:1.18	Fri Jul  9 09:10:26 2004
+++ movitz/compiler-types.lisp	Wed Jul 28 17:12:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.18 2004/07/09 16:10:26 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.19 2004/07/29 00:12:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -351,7 +351,7 @@
   (let ((x (or (= -1 code)
 	       (and (member x members :test #'movitz-eql) t)
 	       (cond
-		((typep x 'movitz-nil)
+		((typep x 'movitz-null)
 		 (type-code-p 'symbol code))
 		((basic-typep x 'fixnum)
 		 (or (type-code-p 'integer code)




From ffjeld at common-lisp.net  Thu Jul 29 00:12:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:12:54 -0700
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BpyXW-0005g0-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:12:54 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.86 movitz/compiler.lisp:1.87
--- movitz/compiler.lisp:1.86	Wed Jul 28 03:00:20 2004
+++ movitz/compiler.lisp	Wed Jul 28 17:12:54 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.86 2004/07/28 10:00:20 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.87 2004/07/29 00:12:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3679,7 +3679,7 @@
     (case op
       (:movl
        (etypecase movitz-obj
-	 (movitz-nil
+	 (movitz-null
 	  (ecase (result-mode-type result-mode)
 	    (:lexical-binding
 	     (make-store-lexical result-mode :edi nil frame-map))
@@ -4369,7 +4369,7 @@
 			    ,optional-ok-label)))))
 	     (when rest-var
 	       (let* ((rest-binding (movitz-binding rest-var env))
-		      (rest-position (function-argument-argnum rest-binding)))
+		      #+ignore (rest-position (function-argument-argnum rest-binding)))
 		 #+ignore
 		 (assert (or (typep rest-binding 'hidden-rest-function-argument)
 			     (movitz-env-get rest-var 'dynamic-extent nil env))
@@ -4377,8 +4377,7 @@
 		   "&REST variable ~S must be dynamic-extent." rest-var)
 		 ;; (setq need-normalized-ecx-p t)
 		 (append #+ignore (make-immediate-move rest-position :edx)
-			 `(#+ignore
-			   (:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))
+			 `(#+ignore (:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))
 			   (:init-lexvar ,rest-binding
 					 :init-with-register :eax
 					 :init-with-type list)))))
@@ -4796,8 +4795,8 @@
 		   (t (error "Don't know ECX mode ~S." returns-provided)))))
 	       (:boolean-cf=1
 		(values (append code
-				`((:sbbl :ecx :ecx)
-				  (:movl (:edi (:ecx 4) ,(global-constant-offset 'null-cons))
+				`((:sbbl :ecx :ecx) ; T => -1, NIL => 0
+				  (:movl (:edi (:ecx 4) ,(global-constant-offset 'not-not-nil))
 					 :eax)))
 			:eax))
 	       (#.+boolean-modes+
@@ -5632,7 +5631,7 @@
     (if (eq movitz-obj (image-t-symbol *image*))
 	(make-indirect-reference :edi (global-constant-offset 't-symbol))
       (etypecase movitz-obj
-	(movitz-nil :edi)
+	(movitz-null :edi)
 	(movitz-immediate-object (movitz-immediate-value movitz-obj))
 	(movitz-heap-object 
 	 (make-indirect-reference :esi (movitz-funobj-intern-constant funobj movitz-obj)))))))




From ffjeld at common-lisp.net  Thu Jul 29 00:13:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:13:00 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BpyXc-000601-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:00 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.53 movitz/image.lisp:1.54
--- movitz/image.lisp:1.53	Wed Jul 28 03:00:33 2004
+++ movitz/image.lisp	Wed Jul 28 17:13:00 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.53 2004/07/28 10:00:33 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.54 2004/07/29 00:13:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -119,16 +119,21 @@
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
    ;; function global constants
-   (unbound-function
-    :binary-type word
-    :binary-tag :global-function
-    :map-binary-read-delayed 'movitz-word
-    :map-binary-write 'movitz-intern)   
+;;;   (unbound-function
+;;;    :binary-type word
+;;;    :binary-tag :global-function
+;;;    :map-binary-read-delayed 'movitz-word
+;;;    :map-binary-write 'movitz-intern)   
    ;; per thread parameters
    (dynamic-env
     :binary-type lu32
     :initform 0)
    ;; More per-thread parameters
+   (unwind-protect-tag
+    :binary-type word
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-read-and-intern
+    :initform 'muerte::unwind-protect-tag)
    (restart-tag
     :binary-type word
     :map-binary-read-delayed 'movitz-word
@@ -141,18 +146,8 @@
     :binary-type word			; in order for the bound instruction to work.
     :initform #x100000)
    ;;
-   (unbound-value
-    :binary-type word
-    :map-binary-read-delayed 'movitz-word
-    :map-binary-write 'movitz-read-and-intern
-    :initform 'muerte::unbound)
-   (unwind-protect-tag
-    :binary-type word
-    :map-binary-read-delayed 'movitz-word
-    :map-binary-write 'movitz-read-and-intern
-    :initform 'muerte::unwind-protect-tag)
    (boolean-one :binary-type :label)
-   (not-nil				; not-nil, t-symbol and null-cons must be consecutive.
+   (not-nil				; not-nil, t-symbol and not-not-nil must be consecutive.
     :binary-type word
     :initform nil
     :map-binary-write 'movitz-read-and-intern
@@ -163,13 +158,21 @@
     :initarg :t-symbol
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word)
-   (null-cons
-    :binary-type movitz-nil
-    :initarg :null-cons)
-   (null-sym
-    :binary-type movitz-nil-symbol
+   (not-not-nil
+    :binary-type word
+    :initform nil
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed 'movitz-word)
+   ;;   (null-cons :binary-type :label)
+   (null-symbol
+    :binary-type movitz-symbol
     :reader movitz-run-time-context-null-symbol
-    :initarg :null-sym)
+    :initarg :null-symbol)
+   (unbound-value
+    :binary-type word
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-read-and-intern
+    :initform 'muerte::unbound)
    ;; primitive functions global constants
    (dynamic-find-binding
     :map-binary-write 'movitz-intern-code-vector
@@ -480,7 +483,7 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function))
-  (:slot-align null-cons -1))
+  (:slot-align null-symbol -5))
 
 (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)
   (bt:enum-value 'movitz::atomically-status
@@ -511,15 +514,17 @@
 
 (defun global-constant-offset (slot-name)
   (check-type slot-name symbol)
-  
-  (slot-offset 'movitz-run-time-context
-	       (intern (symbol-name slot-name) :movitz)))
+  (let ((slot-name (find-symbol (symbol-name slot-name) :movitz)))
+    (assert slot-name)
+    (if (not (eq slot-name 'unbound-function))
+	(slot-offset 'movitz-run-time-context slot-name)
+      (+ (slot-offset 'movitz-run-time-context 'null-symbol)
+	 (slot-offset 'movitz-symbol 'function-value)))))
 
 (defun make-movitz-run-time-context ()
   (make-instance 'movitz-run-time-context
     :t-symbol (movitz-read 't)
-    :null-cons *movitz-nil*
-    :null-sym (movitz-nil-sym *movitz-nil*)))
+    :null-symbol  *movitz-nil*))
 
 (defclass image ()
   ((ds-segment-base
@@ -560,6 +565,9 @@
     :accessor image-symbol-hash-key-counter)
    (nil-word
     :accessor image-nil-word)
+   (nil-object
+    :initarg :nil-object
+    :accessor image-nil-object)
    (t-symbol
     :accessor image-t-symbol)
    (bootblock
@@ -639,7 +647,7 @@
       ()
     "The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object))
   (etypecase object
-    (movitz-nil
+    (movitz-null
      (image-nil-word image))
     (movitz-heap-object
      (+ (movitz-object-offset object)
@@ -778,6 +786,7 @@
 
 (defun make-movitz-image (start-address)
   (let ((*image* (make-instance 'symbolic-image
+		   :nil-object (make-movitz-nil)
 		   :start-address start-address
 		   :movitz-features '(:movitz)
 		   :function-code-sizes
@@ -785,8 +794,8 @@
 		       (copy-hash-table (function-code-sizes *image*))
 		     (make-hash-table :test #'equal)))))
     (setf (image-nil-word *image*)
-      (1+ (- (slot-offset 'movitz-run-time-context 'null-cons)
-	     (slot-offset 'movitz-run-time-context 'run-time-context-start))))
+      (+ 5 (- (slot-offset 'movitz-run-time-context 'null-symbol)
+	      (slot-offset 'movitz-run-time-context 'run-time-context-start))))
     (format t "~&;; NIL value: #x~X.~%" (image-nil-word *image*))
     (assert (eq :null (extract-tag (image-nil-word *image*))) ()
       "NIL value #x~X has tag ~D, but it must be ~D."
@@ -914,10 +923,13 @@
 											   ;; do (warn "sp: ~S ~S" symbol plist)
 	      do (let ((x (movitz-read symbol)))
 		   (typecase x
+		     (movitz-null)
 		     (movitz-symbol
 		      (setf (movitz-plist x)
-			(movitz-read (translate-program plist :cl :muerte.cl))))
-		     (movitz-nil)
+			(movitz-read (translate-program (loop for (property value) on plist by #'cddr
+							    unless (member property '(special constantp))
+							    append (list property value))
+							:cl :muerte.cl))))
 		     (t (warn "not a symbol for plist: ~S has ~S" symbol plist)))))
 	  ;; pull in global properties
 	  (loop for var in (image-compile-time-variables *image*)
@@ -1479,7 +1491,7 @@
 (defun movitz-make-upload-form (object &optional (quotep t))
   "Not completed."
   (typecase object
-    ((or movitz-nil null) "()")
+    ((or movitz-null null) "()")
     (cons
      (format nil "(list~{ ~A~})"
 	     (mapcar #'movitz-make-upload-form object)))
@@ -1547,7 +1559,7 @@
     (symbol expr)
     (array expr)
     (cons (mapcar #'movitz-print expr))
-    ((or movitz-nil movitz-run-time-context) nil)
+    ((or (satisfies movitz-null) movitz-run-time-context) nil)
     (movitz-fixnum
      (movitz-fixnum-value expr))
     (movitz-std-instance expr)




From ffjeld at common-lisp.net  Thu Jul 29 00:13:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:13:09 -0700
Subject: [movitz-cvs] CVS update: movitz/movitz.lisp 
Message-ID: <E1BpyXl-000651-00@common-lisp.net>

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

Modified Files:
	movitz.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:09 2004
Author: ffjeld

Index: movitz/movitz.lisp
diff -u movitz/movitz.lisp:1.8 movitz/movitz.lisp:1.9
--- movitz/movitz.lisp:1.8	Wed Jul 21 15:28:48 2004
+++ movitz/movitz.lisp	Wed Jul 28 17:13:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Oct  9 20:52:58 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: movitz.lisp,v 1.8 2004/07/21 22:28:48 ffjeld Exp $
+;;;; $Id: movitz.lisp,v 1.9 2004/07/29 00:13:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,9 @@
 (defvar *ii* nil)			; for interactive use.
 
 (defvar *image*)
+
+(define-symbol-macro *movitz-nil*
+    (image-nil-object *image*))
 
 (define-unsigned lu16 2 :little-endian)
 (define-unsigned lu32 4 :little-endian)




From ffjeld at common-lisp.net  Thu Jul 29 00:13:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:13:13 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BpyXp-000694-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:13 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.34 movitz/storage-types.lisp:1.35
--- movitz/storage-types.lisp:1.34	Wed Jul 28 03:00:50 2004
+++ movitz/storage-types.lisp	Wed Jul 28 17:13:13 2004
@@ -9,14 +9,12 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.34 2004/07/28 10:00:50 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.35 2004/07/29 00:13:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (in-package movitz)
 
-(defvar *movitz-nil* nil)
-
 ;; (defconstant +tag-other+ 6)
 
 (define-unsigned lu64 8 :little-endian)
@@ -276,14 +274,14 @@
 
 (defun print-cons (ic stream)
   (typecase (movitz-cdr ic)
-    (movitz-nil (format stream "~A" (movitz-car ic)))
+    (movitz-null (format stream "~A" (movitz-car ic)))
     (movitz-cons (format stream "~A " (movitz-car ic)))
     (t (format stream "~A . ~A" (movitz-car ic) (movitz-cdr ic)))))
 
 (defun movitz-list-length (x)
   (etypecase x
     (list (list-length x))
-    (movitz-nil 0)
+    (movitz-null 0)
     (movitz-cons
      (flet ((movitz-endp (x) (eq x *movitz-nil*)))
        (do ((n 0 (+ n 2))		;Counter.
@@ -533,38 +531,38 @@
 ;;; Symbols
 
 (define-binary-class movitz-symbol (movitz-heap-object)
-  ((value
-    :binary-type word
-    :map-binary-write 'movitz-read-and-intern
-    :map-binary-read-delayed 'movitz-word
-    :initform 'muerte::unbound	;
-    :accessor movitz-symbol-value
-    :initarg value)
-   (function-value
+  ((function-value
     :binary-type word
     :accessor movitz-symbol-function-value
     :map-binary-write 'movitz-read-and-intern-function-value
     :map-binary-read-delayed 'movitz-word
-    :initarg function-value
-    :initform 'muerte::unbound)
+    :initarg :function-value
+    :initform 'muerte::unbound-function)
+   (value
+    :binary-type word
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed 'movitz-word
+    :initform 'muerte::unbound		;
+    :accessor movitz-symbol-value
+    :initarg :value)
    (plist
     :binary-type word
     :accessor movitz-plist
-    :map-binary-write 'movitz-intern
+    :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word
-    :initform *movitz-nil*
-    :initarg plist)
+    :initform nil
+    :initarg :plist)
    (name
     :binary-type word
-    :map-binary-write 'movitz-intern
+    :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word
-    :initarg name
+    :initarg :name
     :accessor movitz-symbol-name)
    (package
     :binary-type word
-    :map-binary-write 'movitz-intern
+    :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word
-    :initform *movitz-nil*
+    :initform nil
     :accessor movitz-symbol-package)
    (flags
     :binary-type (define-bitfield movitz-symbol-flags (lu16)
@@ -573,6 +571,7 @@
 		     :constant-variable 4
 		     :setf-placeholder 5)))
     :accessor movitz-symbol-flags
+    :initarg :flags
     :initform nil)
    (hash-key
     :binary-lisp-type lu16
@@ -581,7 +580,7 @@
    (lisp-symbol
     :initform nil
     :initarg :lisp-symbol))
-  (:slot-align value -7))
+  (:slot-align function-value -7))
 
 #+ignore
 (defmethod write-binary-record :before ((obj movitz-symbol) stream)
@@ -604,7 +603,7 @@
   (let ((name-string (image-read-intern-constant *image* (symbol-name name))))
     (make-instance 'movitz-symbol
       :hash-key (movitz-sxhash name-string)
-      'name name-string
+      :name name-string
       :lisp-symbol name)))
 
 (defmethod print-object ((object movitz-symbol) stream)
@@ -620,8 +619,6 @@
 (defun movitz-read-and-intern-function-value (obj type)
   (assert (eq type 'word))
   (cond
-   ((eq 'muerte::unbound obj)
-    (binary-slot-value (image-run-time-context *image*) 'unbound-function))
    ((typep obj 'movitz-funobj)
     (movitz-intern obj))
    ((symbolp obj)
@@ -632,90 +629,26 @@
 
 ;;; NIL
 
-(define-binary-class movitz-nil (movitz-heap-object)
-  ((car :binary-type word
-	:map-binary-read-delayed 'movitz-word
-	:map-binary-write 'movitz-intern)
-   (cdr :binary-type word
-	:map-binary-read-delayed 'movitz-word
-	:map-binary-write 'movitz-intern)
-   (sym :reader movitz-nil-sym)))
-
-(defmethod movitz-object-offset ((obj movitz-nil)) (error "xxx"))
-(defmethod movitz-symbol-value ((obj movitz-nil)) obj)
-
-(defmethod update-movitz-object ((obj movitz-nil) lisp-obj)
-  (declare (ignore lisp-obj))
-  (values))
-
-(defmethod movitz-car ((x movitz-nil)) x)
-(defmethod movitz-cdr ((x movitz-nil)) x)
-
-(define-binary-class movitz-nil-symbol (movitz-symbol)
-  ((value
-    :binary-type word
-    :initform nil
-    :map-binary-write 'movitz-read-and-intern
-    :map-binary-read-delayed 'movitz-word)
-   (function-value
-    :initarg function-value
-    :initform 'muerte::unbound
-    :binary-type word
-    :map-binary-write 'movitz-read-and-intern-function-value
-    :map-binary-read-delayed 'movitz-word)
-   (plist
-    :binary-type word
-    :initform nil
-    :map-binary-write 'movitz-intern
-    :map-binary-read-delayed 'movitz-word)
-   (name
-    :binary-type word
-    :map-binary-write 'movitz-intern
-    :map-binary-read-delayed 'movitz-word)
-   (package
-    :binary-type word
-    :initform *movitz-nil*
-    :map-binary-write 'movitz-intern
-    :map-binary-read-delayed 'movitz-word)
-   (hash-key
-    :binary-lisp-type lu16)
-   (flags
-    :binary-type movitz-symbol-flags
-    :initform '(:constant-variable)))
-  (:slot-align value 7))
-
-(defmethod movitz-intern ((object movitz-nil-symbol) &optional type)
-  (declare (ignore type))
-  (image-intern-object *image* object))
 
-;;;(defmethod movitz-intern ((obj movitz-nil))
-;;;  (declare (special *image*))
-;;;  (princ (image-nil-value *image*)))
+(define-binary-class movitz-null (movitz-symbol) ())
 
 (defun make-movitz-nil ()
-  (let ((new-nil (make-instance 'movitz-nil)))
-    (setf (slot-value new-nil 'car) new-nil
-	  (slot-value new-nil 'cdr) new-nil)
-    (let ((*movitz-nil* new-nil))
-      (setf (slot-value new-nil 'sym)
-	(make-instance 'movitz-nil-symbol
-	  'name (make-movitz-string "NIL")
-	  'value new-nil
-	  'function-value 'muerte::unbound
-	  'plist new-nil
-	  :hash-key (if (not (boundp '*image*)) 0
-		      (logand #xffff (incf (image-symbol-hash-key-counter *image*)))))))
-    new-nil))
+  (make-instance 'movitz-null
+    :name (symbol-name nil)
+    :value nil
+    :plist nil
+    :hash-key 0
+    :flags '(:constant-variable)))
+
+(defmethod movitz-intern ((object movitz-null) &optional (type 'word))
+  (assert (eq 'word type))
+  (image-nil-word *image*))
 
 (defun movitz-null (x)
-  (eq x *movitz-nil*))
+  (typep x 'movitz-null))
 
 (deftype movitz-list ()
-  `(or movitz-cons (satisfies movitz-null)))
-
-(defmethod movitz-intern ((obj movitz-nil) &optional type)
-  (declare (ignore type))
-  (image-nil-word *image*))
+  `(or movitz-cons movitz-null))
 
 ;;; Compiled funobj
 
@@ -1046,7 +979,8 @@
 (defun movitz-sxhash (object)
   "Must match the SXHASH function in :cl/hash-tables."
   (typecase object
-    (movitz-nil 0)
+    (movitz-null
+     0)
     (movitz-symbol
      (movitz-symbol-hash-key object))
     (movitz-string
@@ -1134,9 +1068,9 @@
 					     
 ;;;
 
-(unless (typep *movitz-nil* 'movitz-nil)
-  (warn "Creating new *MOVITZ-NIL* object!")
-  (setf *movitz-nil* (make-movitz-nil)))
+;;;(unless (typep *movitz-nil* 'movitz-nil)
+;;;  (warn "Creating new *MOVITZ-NIL* object!")
+;;;  (setf *movitz-nil* (make-movitz-nil)))
 
 
 (define-binary-class gate-descriptor ()
@@ -1218,8 +1152,8 @@
    (pad :binary-lisp-type 3)
    (dummy
     :binary-type word
-    :initform *movitz-nil*
-    :map-binary-write 'movitz-intern
+    :initform nil
+    :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word)
    (class
     :binary-type word




From ffjeld at common-lisp.net  Thu Jul 29 00:13:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:13:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BpyXu-0006CA-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:18 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.33 movitz/losp/muerte/basic-macros.lisp:1.34
--- movitz/losp/muerte/basic-macros.lisp:1.33	Fri Jul 23 07:36:47 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 28 17:13:18 2004
@@ -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.33 2004/07/23 14:36:47 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.34 2004/07/29 00:13:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1040,7 +1040,8 @@
      (do-case (t :boolean-cf=1 :labels (boundp-done))
        (:compile-form (:result-mode :eax) ,symbol)
        (:cmpl :edi :eax)
-       (:je 'boundp-done)		; if ZF=0, then CF=0
+       (:cmc)
+       (:je 'boundp-done)		; if ZF=1, then CF=1 after CMC
        (:call-local-pf dynamic-find-binding)
        (:jc 'boundp-done)
        (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax)
@@ -1054,6 +1055,9 @@
   `(progn
      (defparameter ,name ,init-form ,docstring)
      (define-symbol-macro ,name (%symbol-global-value ',name))))
+
+(define-compiler-macro assembly-register (register)
+  `(with-inline-assembly (:returns ,register)))
 
 (require :muerte/setf)
 




From ffjeld at common-lisp.net  Thu Jul 29 00:13:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 17:13:22 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1BpyXy-0006DO-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:22 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.17 movitz/losp/muerte/symbols.lisp:1.18
--- movitz/losp/muerte/symbols.lisp:1.17	Thu Jul 15 14:07:32 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Jul 28 17:13:22 2004
@@ -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.17 2004/07/15 21:07:32 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.18 2004/07/29 00:13:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,6 +21,23 @@
 
 (in-package muerte)
 
+(define-compiler-macro get-symbol-slot (object slot &optional (type t))
+  "Read a slot off a symbol (including NIL)."
+  `(with-inline-assembly (:returns :eax :type ,type)
+     (:compile-form (:result-mode :eax) ,object)
+     (:leal (:eax ,(- (movitz:tag :null))) :ecx)
+     (:andl 7 :ecx)
+     (:testb 5 :cl)
+     (:jnz '(:sub-program (not-a-symbol)
+	     (:compile-form (:result-mode :ignore)
+	      (error-not-symbol (assembly-register :eax)))))
+     (:xorl 2 :ecx)
+     (:movl (:eax :ecx (:offset movitz-symbol ,slot))
+	    :eax)))
+
+(defun error-not-symbol (x)
+  (error 'type-error :expected-type 'symbol :datum x))
+
 (defun symbol-value (symbol)
   "Returns the dynamic value of SYMBOL."
   (etypecase symbol
@@ -40,7 +57,7 @@
     (:movl (:eax) :eax)
     (:jmp 'done)
    no-local-binding
-    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)) :eax)
+    (:movl (:eax (:offset movitz-symbol value)) :eax)
    done))
 
 (defun (setf symbol-value) (value symbol)
@@ -70,12 +87,7 @@
   (setf (%symbol-global-value symbol) value))
 
 (defun symbol-function (symbol)
-  (let ((function-value
-	 (etypecase symbol
-	   (null
-	    (movitz-accessor symbol movitz-nil-symbol function-value))
-	   (symbol
-	    (movitz-accessor symbol movitz-symbol function-value)))))
+  (let ((function-value (get-symbol-slot symbol function-value)))
     (when (eq function-value (load-global-constant movitz::unbound-function))
       (error 'undefined-function :name symbol))
     function-value))
@@ -90,14 +102,9 @@
   (setf-movitz-accessor (symbol movitz-symbol function-value) value))
 
 (defun symbol-name (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol name))
-    (symbol 
-     (movitz-accessor symbol movitz-symbol name))))
+  (get-symbol-slot symbol name string))
 
 (defun (setf symbol-name) (value symbol)
-  (check-type value string)
   (etypecase symbol
     (null
      (error "Can't change the name of NIL."))
@@ -105,11 +112,7 @@
      (setf-movitz-accessor (symbol movitz-symbol name) value))))
 
 (defun symbol-plist (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol plist))
-    (symbol 
-     (movitz-accessor symbol movitz-symbol plist))))
+  (get-symbol-slot symbol plist))
 
 (defun (setf symbol-plist) (value symbol)
   (etypecase symbol
@@ -119,11 +122,7 @@
      (setf-movitz-accessor (symbol movitz-symbol plist) value))))
 
 (defun symbol-package (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol package))
-    (symbol
-     (movitz-accessor symbol movitz-symbol package))))
+  (get-symbol-slot symbol package))
 
 (defun boundp (symbol)
   (boundp symbol))
@@ -134,11 +133,8 @@
   symbol)
 
 (defun fboundp (symbol)
-  (etypecase symbol
-    (null nil)
-    (symbol
-     (not (eq (movitz-accessor symbol movitz-symbol function-value)
-	      (load-global-constant movitz::unbound-function))))))
+  (not (eq (get-symbol-slot symbol function-value)
+	   (load-global-constant movitz::unbound-function))))
 
 (defun %create-symbol (name &optional (package nil)
 				      (plist nil)




From ffjeld at common-lisp.net  Thu Jul 29 01:24:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 18:24:45 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1Bpzf3-00038c-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Smarted up the defpackage macro slightly.

Date: Wed Jul 28 18:24:45 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.34 movitz/losp/muerte/basic-macros.lisp:1.35
--- movitz/losp/muerte/basic-macros.lisp:1.34	Wed Jul 28 17:13:18 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Jul 28 18:24:45 2004
@@ -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.34 2004/07/29 00:13:18 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.35 2004/07/29 01:24:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -70,16 +70,16 @@
 			    ,(cons 'cl:progn body)))
 
 (defmacro defpackage (package-name &rest options)
-  (pushnew '(:use) options :key #'car)
-  (let ((uses (cdr (assoc :use options))))
+  (let ((uses (if (not (assoc :use options))
+		  (list 'muerte.cl)
+		(cdr (assoc :use options)))))
     (setf uses (mapcar (lambda (use)
 			 (if (member use (cons :common-lisp (package-nicknames :common-lisp))
 				     :test #'string=)
 			     :muerte.cl
 			   use))
 		       uses))
-    (when (or (null uses)
-	      (member :muerte.cl uses :test #'string=)
+    (when (or (member :muerte.cl uses :test #'string=)
 	      (member :muerte.common-lisp uses :test #'string=))
       (push '(:shadowing-import-from :common-lisp nil) options))
     (let ((movitz-options (cons (cons :use uses)




From ffjeld at common-lisp.net  Thu Jul 29 01:37:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 18:37:11 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bpzr5-0007K3-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Try to protect against slurping in symbols from the common-lisp package.

Date: Wed Jul 28 18:37:10 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.54 movitz/image.lisp:1.55
--- movitz/image.lisp:1.54	Wed Jul 28 17:13:00 2004
+++ movitz/image.lisp	Wed Jul 28 18:37:10 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.54 2004/07/29 00:13:00 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.55 2004/07/29 01:37:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1111,14 +1111,9 @@
 		    sum)))))
 
 (defun intern-movitz-symbol (name)
-  #+ignore (assert (or (not (symbol-package name))
-		       (eq (symbol-package name)
-			   (find-package :keyword))
-		       (string= (string :muerte.)
-				(package-name (symbol-package name))
-				:end2 (min 5 (length (package-name (symbol-package name))))))
-	       (name)
-	     "Trying to movitz-intern a symbol not in a Movitz package: ~S" name)
+  (assert (not (eq (symbol-package name) (find-package :common-lisp)))
+      (name)
+    "Trying to movitz-intern a symbol in the Common-Lisp package: ~S" name)
   (or (gethash name (image-oblist *image*))
       (let ((symbol (make-movitz-symbol name)))
 	(when (get name :setf-placeholder)




From ffjeld at common-lisp.net  Thu Jul 29 01:59:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 18:59:13 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bq0CP-0006Jl-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
(global-constant-offset 'unbound-function) was calculated incorrectly.

Date: Wed Jul 28 18:59:13 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.55 movitz/image.lisp:1.56
--- movitz/image.lisp:1.55	Wed Jul 28 18:37:10 2004
+++ movitz/image.lisp	Wed Jul 28 18:59:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.55 2004/07/29 01:37:10 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.56 2004/07/29 01:59:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -519,7 +519,8 @@
     (if (not (eq slot-name 'unbound-function))
 	(slot-offset 'movitz-run-time-context slot-name)
       (+ (slot-offset 'movitz-run-time-context 'null-symbol)
-	 (slot-offset 'movitz-symbol 'function-value)))))
+	 (slot-offset 'movitz-symbol 'function-value)
+	 (tag :symbol)))))
 
 (defun make-movitz-run-time-context ()
   (make-instance 'movitz-run-time-context




From ffjeld at common-lisp.net  Thu Jul 29 02:14:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 28 Jul 2004 19:14:35 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1Bq0RH-00023U-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Calculate correct sxhash for lower-case strings.

Date: Wed Jul 28 19:14:35 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.35 movitz/storage-types.lisp:1.36
--- movitz/storage-types.lisp:1.35	Wed Jul 28 17:13:13 2004
+++ movitz/storage-types.lisp	Wed Jul 28 19:14:35 2004
@@ -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.35 2004/07/29 00:13:13 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.36 2004/07/29 02:14:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -990,8 +990,8 @@
 	 (incf result result)
 	 (incf result
 	       (if (evenp i)
-		   (char-code (aref object i))
-		 (* 7 (char-code (aref object i))))))
+		   (char-code (char-upcase (aref object i)))
+		 (* 7 (char-code (char-upcase (aref object i)))))))
        (ldb (byte 16 0)
 	    (+ (* #x10ad (length object))
 	       result))))




From ffjeld at common-lisp.net  Thu Jul 29 12:48:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 05:48:35 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <E1BqAKp-0002rH-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv10906

Modified Files:
	textmode.lisp 
Log Message:
Tweaked textmode-scroll-down.

Date: Thu Jul 29 05:48:35 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.8 movitz/losp/x86-pc/textmode.lisp:1.9
--- movitz/losp/x86-pc/textmode.lisp:1.8	Mon Jul 12 02:12:40 2004
+++ movitz/losp/x86-pc/textmode.lisp	Thu Jul 29 05:48:35 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.8 2004/07/12 09:12:40 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.9 2004/07/29 12:48:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -127,10 +127,11 @@
   (declare (special muerte.lib::*scroll-offset*))
   (incf muerte.lib::*scroll-offset*)
   (loop with stride = (* 2 *screen-stride*)
-      for y below *screen-height*
+      for y below (1- *screen-height*)
       as src from (+ *screen* stride) by stride
       as dst from *screen* by stride
-      do (textmode-copy-line dst src *screen-width*))
+      do (textmode-copy-line dst src *screen-width*)
+      finally (textmode-clear-line 0 (1- *screen-height*)))
   (signal 'newline))
 
 (defun textmode-clear-line (from-column line)




From ffjeld at common-lisp.net  Thu Jul 29 12:51:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 05:51:41 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1BqANp-00061A-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Fixed objects-equalp for symbols.

Date: Thu Jul 29 05:51:40 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.33 movitz/losp/muerte/inspect.lisp:1.34
--- movitz/losp/muerte/inspect.lisp:1.33	Wed Jul 28 03:01:06 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Jul 29 05:51:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.33 2004/07/28 10:01:06 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.34 2004/07/29 12:51:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -229,12 +229,12 @@
 		  (dotimes (i (funobj-num-constants x) t)
 		    (unless (test funobj-constant-ref i)))))
 	    (symbol
-	     (and ;; (test memref -7 0 :lisp) ; value
-		  (test memref -7 1 :lisp)    ; function-value
-		  ;; (test memref -7 2 :lisp) ; plist
-		  (test memref -7 3 :lisp)    ; name
-		  ;; (test memref -7 4 :lisp) ; package
-		  (test memref -7 5 :lisp))) ; flags
+	     (and (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::function-value)
+			0 :lisp)
+		  (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::name)
+			0 :lisp)
+		  (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::flags)
+			0 :lisp)))
 	    (vector
 	     (and (typep y 'vector)
 		  (test array-element-type)




From ffjeld at common-lisp.net  Thu Jul 29 16:18:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 09:18:47 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BqDcF-0001WS-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added support for movitz-read'ing ratios.

Date: Thu Jul 29 09:18:47 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.56 movitz/image.lisp:1.57
--- movitz/image.lisp:1.56	Wed Jul 28 18:59:13 2004
+++ movitz/image.lisp	Thu Jul 29 09:18:47 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.56 2004/07/29 01:59:13 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.57 2004/07/29 16:18:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1426,61 +1426,75 @@
      (declare (special *movitz-reader-clean-map*))
      , at body))
 
-(defun movitz-read (expr)
+(defun movitz-read (expr &optional re-read)
   "Map native lisp data to movitz-objects. Makes sure that when two EXPR are EQ, ~@
    the Movitz objects are also EQ, under the same image."
   (declare (optimize (debug 3) (speed 0)))
   (with-movitz-read-context ()
     (when (typep expr 'movitz-object)
       (return-from movitz-read expr))
-    (or
-     (let ((old-object (image-lisp-to-movitz-object *image* expr)))
-       (when (and old-object (not (gethash old-object *movitz-reader-clean-map*)))
-	 (update-movitz-object old-object expr)
-	 (setf (gethash old-object *movitz-reader-clean-map*) t))
-       old-object)
-     (setf (image-lisp-to-movitz-object *image* expr)
-       (etypecase expr
-	 (null *movitz-nil*)
-	 ((member t) (movitz-read 'muerte.cl:t))
-	 (symbol (intern-movitz-symbol expr))
-	 (integer (make-movitz-integer expr))
-	 (character (make-movitz-character expr))
-	 (string (or (gethash expr (image-string-constants *image*))
-		     (setf (gethash expr (image-string-constants *image*))
-		       (make-movitz-string expr))))
-	 (vector (make-movitz-vector (length expr)
-				     :element-type (array-element-type expr)
-				     :initial-contents expr))
-	 (cons
-	  (or (gethash expr (image-cons-constants *image*))
-	      (setf (gethash expr (image-cons-constants *image*))
-		(if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
-		    (multiple-value-bind (unfolded-expr cdr-index)
-			(unfold-circular-list expr)
-		      (let ((result (movitz-read unfolded-expr)))
-			(setf (movitz-last-cdr result)
-			  (movitz-nthcdr cdr-index result))
-			result))
-		  (make-movitz-cons (movitz-read (car expr))
-				    (movitz-read (cdr expr)))))))
-	 (hash-table
-	  (make-movitz-hash-table expr))
-	 (structure-object
-	  (let ((slot-descriptions (gethash (type-of expr)
-					    (image-struct-slot-descriptions *image*)
-					    nil)))
-	    (unless slot-descriptions
-	      (error "Don't know how to movitz-read struct: ~S" expr))
-	    (let ((movitz-object (make-instance 'movitz-struct
-				   :class (muerte::movitz-find-class (type-of expr))
-				   :length (length slot-descriptions))))
-	      (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
-	      (setf (slot-value movitz-object 'slot-values)
-		(mapcar #'(lambda (slot)
-			    (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
-			slot-descriptions))
-	      movitz-object))))))))
+    (or (and (not re-read)
+	     (let ((old-object (image-lisp-to-movitz-object *image* expr)))
+	       (when (and old-object (not (gethash old-object *movitz-reader-clean-map*)))
+		 (update-movitz-object old-object expr)
+		 (setf (gethash old-object *movitz-reader-clean-map*) t))
+	       old-object))
+	(setf (image-lisp-to-movitz-object *image* expr)
+	  (etypecase expr
+	    (null *movitz-nil*)
+	    ((member t) (movitz-read 'muerte.cl:t))
+	    (symbol (intern-movitz-symbol expr))
+	    (integer (make-movitz-integer expr))
+	    (character (make-movitz-character expr))
+	    (string (or (gethash expr (image-string-constants *image*))
+			(setf (gethash expr (image-string-constants *image*))
+			  (make-movitz-string expr))))
+	    (vector (make-movitz-vector (length expr)
+					:element-type (array-element-type expr)
+					:initial-contents expr))
+	    (cons
+	     (or (gethash expr (image-cons-constants *image*))
+		 (setf (gethash expr (image-cons-constants *image*))
+		   (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
+		       (multiple-value-bind (unfolded-expr cdr-index)
+			   (unfold-circular-list expr)
+			 (let ((result (movitz-read unfolded-expr)))
+			   (setf (movitz-last-cdr result)
+			     (movitz-nthcdr cdr-index result))
+			   result))
+		     (make-movitz-cons (movitz-read (car expr))
+				       (movitz-read (cdr expr)))))))
+	    (hash-table
+	     (make-movitz-hash-table expr))
+	    (ratio
+	     (let ((slot-descriptions (gethash 'muerte.cl::ratio
+					       (image-struct-slot-descriptions *image*)
+					       nil)))
+	       (unless slot-descriptions
+		 (error "Don't know how to movitz-read ratios (yet)." expr))
+	       (let ((movitz-object (make-instance 'movitz-struct
+				      :class (muerte::movitz-find-class 'muerte.cl::ratio)
+				      :length (length slot-descriptions))))
+		 (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
+		 (setf (slot-value movitz-object 'slot-values)
+		   (list (movitz-read (numerator expr))
+			 (movitz-read (denominator expr))))
+		 movitz-object)))
+	    (structure-object
+	     (let ((slot-descriptions (gethash (type-of expr)
+					       (image-struct-slot-descriptions *image*)
+					       nil)))
+	       (unless slot-descriptions
+		 (error "Don't know how to movitz-read struct: ~S" expr))
+	       (let ((movitz-object (make-instance 'movitz-struct
+				      :class (muerte::movitz-find-class (type-of expr))
+				      :length (length slot-descriptions))))
+		 (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
+		 (setf (slot-value movitz-object 'slot-values)
+		   (mapcar #'(lambda (slot)
+			       (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
+			   slot-descriptions))
+		 movitz-object))))))))
 
 ;;;
 




From ffjeld at common-lisp.net  Thu Jul 29 16:20:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 09:20:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/lib/readline.lisp 
Message-ID: <E1BqDdi-0003NT-00@common-lisp.net>

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

Modified Files:
	readline.lisp 
Log Message:
Minor fix: dont assume the screen is 25 characters high.

Date: Thu Jul 29 09:20:18 2004
Author: ffjeld

Index: movitz/losp/lib/readline.lisp
diff -u movitz/losp/lib/readline.lisp:1.4 movitz/losp/lib/readline.lisp:1.5
--- movitz/losp/lib/readline.lisp:1.4	Fri Feb 13 14:11:19 2004
+++ movitz/losp/lib/readline.lisp	Thu Jul 29 09:20:18 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov  2 13:58:58 2001
 ;;;;                
-;;;; $Id: readline.lisp,v 1.4 2004/02/13 22:11:19 ffjeld Exp $
+;;;; $Id: readline.lisp,v 1.5 2004/07/29 16:20:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -135,7 +135,7 @@
 	when (member key terminator-keys)
 	do (when displayed-completions-p
 	     (do ((y (1+ (cursor-y console)) (1+ y)))
-		 ((>= y 25))
+		 ((>= y (console-height console)))
 	       (clear-line console 0 y)))
 	and return key
 	do (case key




From ffjeld at common-lisp.net  Thu Jul 29 16:20:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 09:20:43 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp 
Message-ID: <E1BqDe7-0004i8-00@common-lisp.net>

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

Modified Files:
	ratios.lisp 
Log Message:
Add a defconstant pi, for the fun of it.

Date: Thu Jul 29 09:20:43 2004
Author: ffjeld

Index: movitz/losp/muerte/ratios.lisp
diff -u movitz/losp/muerte/ratios.lisp:1.1 movitz/losp/muerte/ratios.lisp:1.2
--- movitz/losp/muerte/ratios.lisp:1.1	Tue Jul 27 06:54:12 2004
+++ movitz/losp/muerte/ratios.lisp	Thu Jul 29 09:20:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.1 2004/07/27 13:54:12 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.2 2004/07/29 16:20:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -51,3 +51,5 @@
   (etypecase x
     (integer 1)
     (ratio (ratio-denominator x))))
+
+(defconstant pi #xea7632a/4aa1a8b)




From ffjeld at common-lisp.net  Thu Jul 29 16:21:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 29 Jul 2004 09:21:40 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1BqDf2-0005zh-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Added an imbecile format-float, for ~F.

Date: Thu Jul 29 09:21:39 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.5 movitz/losp/muerte/format.lisp:1.6
--- movitz/losp/muerte/format.lisp:1.5	Thu May 20 10:47:24 2004
+++ movitz/losp/muerte/format.lisp	Thu Jul 29 09:21:39 2004
@@ -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.5 2004/05/20 17:47:24 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.6 2004/07/29 16:21:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,6 +59,22 @@
 	  (*print-readably* nil))
       (write x))))
 
+(defun format-float (x &optional at-sign-p colon-p w d k overflowchar padchar)
+  (declare (ignore w k overflowchar padchar at-sign-p colon-p))
+  (multiple-value-bind (integer-part decimal-part)
+      (truncate x)
+    (write-integer integer-part *standard-output* 10 t)
+    (do ((remainder decimal-part)
+	 (i 0 (1+ i)))
+	((if (not d)
+	     (or (and (plusp i) (zerop decimal-part))
+		 (>= i 16))
+	   (= i d)))
+      (multiple-value-bind (next-digit next-remainder)
+	  (truncate (* 10 remainder))
+	(setf remainder next-remainder)
+	(write-integer next-digit *standard-output* 10 nil)))))
+
 (defun find-directive (string i directive &optional recursive-skip-start
 						    (recursive-skip-end directive))
   "Return position of <directive> in <string>, starting search at <i>. Also return
@@ -142,6 +158,7 @@
 				   (nreverse prefix-parameters)))
 	      (#\X (format-integer (pop args) 16 at-sign-p colon-p
 				   (nreverse prefix-parameters)))
+	      (#\F (apply 'format-float (pop args) at-sign-p colon-p (nreverse prefix-parameters)))
 	      (#\C (if colon-p
 		       (let ((c (pop args)))
 			 (write-string (or (char-name c) c)))
@@ -292,3 +309,4 @@
      end-loop)
     (values i args)))
 
+	   




From ffjeld at common-lisp.net  Fri Jul 30 21:06:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 14:06:22 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Bqea6-000137-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Improved support for ratios in compare (i.e. <, <=, >, etc).

Date: Fri Jul 30 14:06:22 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.57 movitz/image.lisp:1.58
--- movitz/image.lisp:1.57	Thu Jul 29 09:18:47 2004
+++ movitz/image.lisp	Fri Jul 30 14:06:22 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.57 2004/07/29 16:18:47 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.58 2004/07/30 21:06:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -294,6 +294,11 @@
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word)
    (complicated-class-of
+    :binary-type word
+    :binary-tag :global-function
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-intern)
+   (complicated-compare
     :binary-type word
     :binary-tag :global-function
     :map-binary-read-delayed 'movitz-word




From ffjeld at common-lisp.net  Fri Jul 30 21:06:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 14:06:27 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BqeaB-00016e-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved support for ratios in compare (i.e. <, <=, >, etc).

Date: Fri Jul 30 14:06:27 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.87 movitz/losp/muerte/integers.lisp:1.88
--- movitz/losp/muerte/integers.lisp:1.87	Tue Jul 27 15:05:14 2004
+++ movitz/losp/muerte/integers.lisp	Fri Jul 30 14:06:27 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.87 2004/07/27 22:05:14 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.88 2004/07/30 21:06:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,11 +47,12 @@
 	    ;; Check that both numbers are bignums, and compare them.
 	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (n1-not-bignum)
-		    (:int 64)))
+	    (:jnz '(:sub-program (go-complicated)
+		    (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi))
+		    (:jmp (:esi (:offset movitz-funobj code-vector%2op)))))
 	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 	    (:cmpb ,(movitz:tag :bignum) :cl)
-	    (:jne 'n1-not-bignum)
+	    (:jne 'go-complicated)
 
 	    (:cmpl :eax :ebx)		; If they are EQ, they are certainly =
 	    (:je '(:sub-program (n1-and-n2-are-eq)
@@ -59,12 +60,10 @@
 
 	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (n2-not-bignum)
-		    (:movl :ebx :eax)
-		    (:int 64)))
+	    (:jnz 'go-complicated)
 	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 	    (:cmpb ,(movitz:tag :bignum) :cl)
-	    (:jne 'n2-not-bignum)
+	    (:jne 'go-complicated)
 
 	    (:cmpb :ch (:eax (:offset movitz-bignum sign)))
 	    (:jne '(:sub-program (different-signs)
@@ -184,9 +183,9 @@
 	   n2-not-fixnum
 	    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
 	    (:testb 7 :cl)
-	    (:jnz '(:sub-program (not-integer)
-		    (:movl :ebx :eax)
-		    (:int 64)))
+	    (:jnz '(:sub-program (go-complicated)
+		    (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi))
+		    (:jmp (:esi (:offset movitz-funobj code-vector%2op)))))
 	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 	    (:cmpw ,(movitz:tag :bignum 0) :cx)
 	    (:jne 'not-plusbignum)
@@ -195,7 +194,7 @@
 	    (:ret)
 	   not-plusbignum
 	    (:cmpw ,(movitz:tag :bignum #xff) :cx)
-	    (:jne 'not-integer)
+	    (:jne 'go-complicated)
 	    ;; compare ebx with something bigger
 	    (:cmpl #x-10000000 :edi)
 	    (:ret))))
@@ -211,8 +210,9 @@
    not-fixnum
     (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
     (:testb 7 :cl)
-    (:jnz '(:sub-program (not-integer)
-	    (:int 64)))
+    (:jnz '(:sub-program (go-complicated)
+	    (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi))
+	    (:jmp (:esi (:offset movitz-funobj code-vector%2op)))))
     (:movl (:eax #.movitz:+other-type-offset+) :ecx)
     (:cmpw #.(movitz:tag :bignum 0) :cx)
     (:jne 'not-plusbignum)
@@ -221,10 +221,19 @@
     (:ret)
    not-plusbignum
     (:cmpw #.(movitz:tag :bignum #xff) :cx)
-    (:jne 'not-integer)
+    (:jne 'go-complicated)
     ;; compare ebx with something bigger
     (:cmpl #x10000000 :edi)
     (:ret)))
+
+(defun complicated-compare (x y)
+  (let ((ix (* (numerator x) (denominator y)))
+	(iy (* (numerator y) (denominator x))))
+    (with-inline-assembly (:returns :multiple-values)
+      (:compile-two-forms (:eax :ebx) ix iy)
+      (:call-global-pf fast-compare-two-reals)
+      (:movl 1 :ecx)			; The real result is in EFLAGS.
+      (:movl :edi :eax))))
 
 ;;;
 




From ffjeld at common-lisp.net  Fri Jul 30 21:06:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 14:06:31 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp 
Message-ID: <E1BqeaF-00019l-00@common-lisp.net>

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

Modified Files:
	ratios.lisp 
Log Message:
Improved support for ratios in compare (i.e. <, <=, >, etc).

Date: Fri Jul 30 14:06:31 2004
Author: ffjeld

Index: movitz/losp/muerte/ratios.lisp
diff -u movitz/losp/muerte/ratios.lisp:1.2 movitz/losp/muerte/ratios.lisp:1.3
--- movitz/losp/muerte/ratios.lisp:1.2	Thu Jul 29 09:20:43 2004
+++ movitz/losp/muerte/ratios.lisp	Fri Jul 30 14:06:31 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.2 2004/07/29 16:20:43 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.3 2004/07/30 21:06:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,7 +26,6 @@
   numerator denominator)
 
 (defun make-rational (numerator denominator)
-  (assert (not (eq 0 denominator)))
   (check-type numerator integer)
   (check-type denominator integer)
   (cond




From ffjeld at common-lisp.net  Fri Jul 30 22:04:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 15:04:18 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp 
Message-ID: <E1BqfUA-0001xx-00@common-lisp.net>

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

Modified Files:
	ratios.lisp 
Log Message:
Rational is the direct superclass of ratio, not number.

Date: Fri Jul 30 15:04:17 2004
Author: ffjeld

Index: movitz/losp/muerte/ratios.lisp
diff -u movitz/losp/muerte/ratios.lisp:1.3 movitz/losp/muerte/ratios.lisp:1.4
--- movitz/losp/muerte/ratios.lisp:1.3	Fri Jul 30 14:06:31 2004
+++ movitz/losp/muerte/ratios.lisp	Fri Jul 30 15:04:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.3 2004/07/30 21:06:31 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.4 2004/07/30 22:04:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,7 +22,7 @@
 (in-package muerte)
 
 (defstruct (ratio (:constructor make-ratio (numerator denominator))
-	    (:superclass number))
+	    (:superclass rational))
   numerator denominator)
 
 (defun make-rational (numerator denominator)




From ffjeld at common-lisp.net  Fri Jul 30 22:10:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 15:10:59 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1Bqfad-0001fG-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved ratio support in +, -, truncate, and compare.

Date: Fri Jul 30 15:10:59 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.88 movitz/losp/muerte/integers.lisp:1.89
--- movitz/losp/muerte/integers.lisp:1.88	Fri Jul 30 14:06:27 2004
+++ movitz/losp/muerte/integers.lisp	Fri Jul 30 15:10:59 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.88 2004/07/30 21:06:27 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.89 2004/07/30 22:10:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -690,14 +690,10 @@
 		 (- x (- y)))
 		(((integer * -1) (integer * -1))
 		 (%negatef (+ (- x) (- y)) x y))
-		((ratio t)
-		 (make-rational (+ (* (ratio-numerator x) (denominator y))
-				   (* (numerator y) (ratio-denominator x)))
-				(* (ratio-denominator x) (denominator y))))
-		((integer ratio)
-		 (make-rational (+ (* x (denominator y))
-				   (* (ratio-numerator y) x))
-				(denominator y)))
+		((rational rational)
+		 (/ (+ (* (numerator x) (denominator y))
+		       (* (numerator y) (denominator x)))
+		    (* (denominator x) (denominator y))))
 		)))
 	(do-it)))
    (t (&rest terms)
@@ -728,7 +724,10 @@
 			(:testb 7 :cl)
 			(:jnz '(:sub-program (not-a-number)
 				(:compile-form (:result-mode :ignore)
-				 (error 'type-error :expected-type 'number :datum x))))
+				 (if (ratio-p x)
+				     (make-rational (- (ratio-numerator x))
+				      (ratio-denominator x))
+				   (error 'type-error :expected-type 'number :datum x)))))
 			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
 			(:cmpb ,(movitz:tag :bignum) :cl)
 			(:jne 'not-a-number)
@@ -834,6 +833,10 @@
 		 (%negatef (+ (- minuend) subtrahend) minuend subtrahend))
 		(((integer * -1) (integer * -1))
 		 (+ minuend (- subtrahend)))
+		((rational rational)
+		 (/ (- (* (numerator minuend) (denominator subtrahend))
+		       (* (numerator subtrahend) (denominator minuend)))
+		    (* (denominator minuend) (denominator subtrahend))))
 		)))
 	(do-it)))
    (t (minuend &rest subtrahends)
@@ -1218,7 +1221,12 @@
    (t (number divisor)
       (number-double-dispatch (number divisor)
 	((t (eql 1))
-	 (values number 0))
+	 (if (not (ratio-p number))
+	     (values number 0)
+	   (multiple-value-bind (q r)
+	       (truncate (ratio-numerator number)
+			 (ratio-denominator number))
+	     (values q (make-rational r (ratio-denominator number))))))
 	((fixnum fixnum)
 	 (with-inline-assembly (:returns :multiple-values)
 	   (:compile-form (:result-mode :eax) number)




From ffjeld at common-lisp.net  Fri Jul 30 22:15:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 30 Jul 2004 15:15:23 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1Bqfet-00078K-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Tune-up of format-float: Round off the last digit properly.

Date: Fri Jul 30 15:15:23 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.6 movitz/losp/muerte/format.lisp:1.7
--- movitz/losp/muerte/format.lisp:1.6	Thu Jul 29 09:21:39 2004
+++ movitz/losp/muerte/format.lisp	Fri Jul 30 15:15:23 2004
@@ -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.6 2004/07/29 16:21:39 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.7 2004/07/30 22:15:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,21 +59,27 @@
 	  (*print-readably* nil))
       (write x))))
 
-(defun format-float (x &optional at-sign-p colon-p w d k overflowchar padchar)
-  (declare (ignore w k overflowchar padchar at-sign-p colon-p))
-  (multiple-value-bind (integer-part decimal-part)
-      (truncate x)
-    (write-integer integer-part *standard-output* 10 t)
-    (do ((remainder decimal-part)
-	 (i 0 (1+ i)))
-	((if (not d)
-	     (or (and (plusp i) (zerop decimal-part))
-		 (>= i 16))
-	   (= i d)))
-      (multiple-value-bind (next-digit next-remainder)
-	  (truncate (* 10 remainder))
-	(setf remainder next-remainder)
-	(write-integer next-digit *standard-output* 10 nil)))))
+(defun format-float (x &optional at-sign-p colon-p w d (k 0) overflowchar padchar)
+  (declare (ignore w overflowchar padchar at-sign-p colon-p))
+  (if (eql 0 d)
+      (write-integer (round x) *standard-output* 10 nil)
+    (multiple-value-bind (integer-part decimal-part)
+	(truncate x)
+      (write-integer integer-part *standard-output* 10 nil)
+      (dotimes (i k)
+	(write-char #\0))
+      (write-char #\.)
+      (do ((remainder decimal-part)
+	   (last-i (if d (1- d) 15))
+	   (i 0 (1+ i)))
+	  ((or (and (not d) (plusp i) (zerop remainder))
+	       (> i last-i)))
+	(multiple-value-bind (next-digit next-remainder)
+	    (if (= i last-i)
+		(round (* 10 remainder))
+	      (truncate (* 10 remainder)))
+	  (setf remainder next-remainder)
+	  (write-digit next-digit *standard-output*))))))
 
 (defun find-directive (string i directive &optional recursive-skip-start
 						    (recursive-skip-end directive))




From ffjeld at common-lisp.net  Sat Jul 31 23:34:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 31 Jul 2004 16:34:52 -0700
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1Br3NM-0005A1-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Changed the implementation of ratios from a defstruct to a built-in
structure.

Date: Sat Jul 31 16:34:52 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.58 movitz/image.lisp:1.59
--- movitz/image.lisp:1.58	Fri Jul 30 14:06:22 2004
+++ movitz/image.lisp	Sat Jul 31 16:34:52 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.58 2004/07/30 21:06:22 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.59 2004/07/31 23:34:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -618,7 +618,7 @@
 (defmethod image-classes-map ((image symbolic-image))
   '(muerte.cl:null muerte.cl:cons muerte.cl:fixnum muerte.cl:symbol
     muerte.cl:character muerte.cl:function muerte.cl:condition
-    muerte.cl:integer muerte.cl:ratio
+    muerte.cl:integer muerte.cl:ratio muerte.cl:complex
     muerte.cl:vector muerte.cl:string muerte.cl:bit-vector muerte.cl:array
     muerte.cl:class muerte.cl:standard-class
     muerte.cl:standard-generic-function
@@ -1472,6 +1472,9 @@
 	    (hash-table
 	     (make-movitz-hash-table expr))
 	    (ratio
+	     (make-instance 'movitz-ratio
+	       :value expr)
+	     #+ignore
 	     (let ((slot-descriptions (gethash 'muerte.cl::ratio
 					       (image-struct-slot-descriptions *image*)
 					       nil)))




From ffjeld at common-lisp.net  Sat Jul 31 23:34:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 31 Jul 2004 16:34:57 -0700
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1Br3NR-0005S2-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Changed the implementation of ratios from a defstruct to a built-in
structure.

Date: Sat Jul 31 16:34:57 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.36 movitz/storage-types.lisp:1.37
--- movitz/storage-types.lisp:1.36	Wed Jul 28 19:14:35 2004
+++ movitz/storage-types.lisp	Sat Jul 31 16:34:57 2004
@@ -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.36 2004/07/29 02:14:35 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.37 2004/07/31 23:34:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -69,6 +69,8 @@
   :basic-vector #x22
   :funobj #x3a
   :bignum #x4a
+  :ratio #x52
+  :complex #x5a
   :defstruct #x20
   :std-instance #x40
   :run-time-context #x50
@@ -1255,3 +1257,38 @@
 	(#x00 x)
 	(#xff (- x))))
     header))
+
+(define-binary-class movitz-ratio (movitz-heap-object-other)
+  ((type
+    :binary-type other-type-byte
+    :initform :ratio)
+   (dummy0
+    :binary-type u8
+    :initform 0)
+   (dummy1
+    :binary-type lu16
+    :initform 0)
+   (dummy2
+    :binary-type word
+    :initform 0)
+   (numerator
+    :binary-type word
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-read-and-intern)
+   (denominator
+    :binary-type word
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-read-and-intern)
+   (value
+    :reader movitz-ratio-value
+    :initarg :value))
+  (:slot-align type #.+other-type-offset+))
+
+(defmethod write-binary-record ((obj movitz-ratio) stream)
+  (declare (ignore stream))
+  (let ((value (movitz-ratio-value obj)))
+    (check-type value ratio)
+    (setf (slot-value obj 'numerator) (numerator value)
+	  (slot-value obj 'denominator) (denominator value))
+    (call-next-method)))
+	 
\ No newline at end of file




From ffjeld at common-lisp.net  Sat Jul 31 23:35:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 31 Jul 2004 16:35:04 -0700
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1Br3NY-0006zY-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Changed the implementation of ratios from a defstruct to a built-in
structure.

Date: Sat Jul 31 16:35:04 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.35 movitz/losp/muerte/primitive-functions.lisp:1.36
--- movitz/losp/muerte/primitive-functions.lisp:1.35	Mon Jul 26 14:02:25 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Sat Jul 31 16:35:03 2004
@@ -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.35 2004/07/26 21:02:25 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.36 2004/07/31 23:35:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -718,6 +718,8 @@
 
 (defun complicated-class-of (object)
   (typecase object
+    (ratio
+     (find-class 'ratio))
     (std-instance
      (movitz-accessor object movitz-std-instance class))
     (standard-gf-instance




From ffjeld at common-lisp.net  Sat Jul 31 23:35:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 31 Jul 2004 16:35:09 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp 
Message-ID: <E1Br3Nd-0007bl-00@common-lisp.net>

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

Modified Files:
	ratios.lisp 
Log Message:
Changed the implementation of ratios from a defstruct to a built-in
structure.

Date: Sat Jul 31 16:35:09 2004
Author: ffjeld

Index: movitz/losp/muerte/ratios.lisp
diff -u movitz/losp/muerte/ratios.lisp:1.4 movitz/losp/muerte/ratios.lisp:1.5
--- movitz/losp/muerte/ratios.lisp:1.4	Fri Jul 30 15:04:17 2004
+++ movitz/losp/muerte/ratios.lisp	Sat Jul 31 16:35:09 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.4 2004/07/30 22:04:17 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.5 2004/07/31 23:35:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,9 +21,37 @@
 
 (in-package muerte)
 
-(defstruct (ratio (:constructor make-ratio (numerator denominator))
-	    (:superclass rational))
-  numerator denominator)
+;;;(defstruct (ratio (:constructor make-ratio (numerator denominator))
+;;;	    (:superclass rational))
+;;;  numerator denominator)
+
+(defun make-ratio (numerator denominator)
+  (check-type numerator integer)
+  (check-type denominator (integer 1 *))
+  (let ((ratio (malloc-pointer-words 4)))
+    (setf (memref ratio #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+		  0 :unsigned-byte32)
+      #.(movitz:tag :ratio))
+    (setf (memref ratio -6 2 :lisp) numerator
+	  (memref ratio -6 3 :lisp) denominator)
+    ratio))
+
+(defun ratio-p (x)
+  (typep x 'ratio))
+
+(define-compiler-macro %ratio-numerator (x)
+  `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp))
+
+(defun ratio-numerator (x)
+  (check-type x ratio)
+  (%ratio-numerator x))
+
+(define-compiler-macro %ratio-denominator (x)
+  `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp))
+
+(defun ratio-denominator (x)
+  (check-type x ratio)
+  (%ratio-denominator x))
 
 (defun make-rational (numerator denominator)
   (check-type numerator integer)
@@ -44,11 +72,11 @@
 (defun numerator (x)
   (etypecase x
     (integer x)
-    (ratio (ratio-numerator x))))
+    (ratio (%ratio-numerator x))))
 
 (defun denominator (x)
   (etypecase x
     (integer 1)
-    (ratio (ratio-denominator x))))
+    (ratio (%ratio-denominator x))))
 
 (defconstant pi #xea7632a/4aa1a8b)




From ffjeld at common-lisp.net  Sat Jul 31 23:35:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 31 Jul 2004 16:35:14 -0700
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1Br3Ni-0007hU-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Changed the implementation of ratios from a defstruct to a built-in
structure.

Date: Sat Jul 31 16:35:14 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.35 movitz/losp/muerte/typep.lisp:1.36
--- movitz/losp/muerte/typep.lisp:1.35	Wed Jul 28 07:50:26 2004
+++ movitz/losp/muerte/typep.lisp	Sat Jul 31 16:35:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.35 2004/07/28 14:50:26 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.36 2004/07/31 23:35:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -179,6 +179,8 @@
 		 (make-other-typep :bignum 0))
 		((negative-bignum)
 		 (make-other-typep :bignum #xff))
+		((ratio)
+		 (make-other-typep :ratio))
 		((integer)
 		 `(with-inline-assembly-case ()
 		    (do-case (t :boolean-zf=1 :labels (done))
@@ -556,12 +558,11 @@
 (define-simple-typep (bignum bignump) (x)
   (typep x 'bignum))
 
+(define-simple-typep (rational rationalp) (x)
+  (typep x '(or fixnum bignum ratio)))
+
 (define-simple-typep (number numberp) (x)
-  "Currently, only integers and ratios are supported."
-  (or (typep x 'fixnum)
-      (and (typep x 'tag6)
-	   (or (typep x 'bignum)
-	       (ratio-p x)))))
+  (typep x 'rational))
 
 (define-simple-typep (function functionp) (x)
   (typep x 'function))