From ffjeld at common-lisp.net  Wed May  5 08:24:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 05 May 2004 04:24:22 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/lib/named-integers.lisp 
Message-ID: <E1BLHhW-0000iu-00@common-lisp.net>

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

Modified Files:
	named-integers.lisp 
Log Message:
Changed the with-named-integers-syntax macro a bit, trying to make
this mechanism a bit more general and useful.

Date: Wed May  5 04:24:22 2004
Author: ffjeld

Index: movitz/losp/lib/named-integers.lisp
diff -u movitz/losp/lib/named-integers.lisp:1.3 movitz/losp/lib/named-integers.lisp:1.4
--- movitz/losp/lib/named-integers.lisp:1.3	Mon Jan 19 06:23:44 2004
+++ movitz/losp/lib/named-integers.lisp	Wed May  5 04:24:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jan  4 16:13:46 2002
 ;;;;                
-;;;; $Id: named-integers.lisp,v 1.3 2004/01/19 11:23:44 ffjeld Exp $
+;;;; $Id: named-integers.lisp,v 1.4 2004/05/05 08:24:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,13 +20,14 @@
 
 (in-package muerte.lib)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel :load-toplevel)
   (defun name->integer (map name)
     (if (integerp name)
 	name
-      (or (etypecase map
-	    (vector (position name map))
-	    (list (car (rassoc name map))))
+      (or (ecase (car map)
+	    (:enum (position name (cdr map)))
+	    (:assoc (cdr (assoc name (cdr map))))
+	    (:rassoc (car (rassoc name (cdr map)))))
 	  (error "No integer named ~S in ~S." name map))))
   (defun names->integer (map &rest names)
     (declare (dynamic-extent names))
@@ -34,11 +35,13 @@
 	sum (name->integer map name))))
 
 (defmacro with-named-integers-syntax (name-maps &body body)
-  `(macrolet ,(mapcar (lambda (name-map)
-			(destructuring-bind (name map)
-			    name-map
-			  `(,name (&rest names) (apply 'muerte.lib:names->integer ,map names))))
-		      name-maps)
+  `(macrolet
+       ,(mapcar (lambda (name-map)
+		  (destructuring-bind (name map)
+		      name-map
+		    `(,name (&rest names)
+			    (apply 'muerte.lib:names->integer ,map names))))
+		name-maps)
      , at body))       
 
 (define-compile-time-variable *name-to-integer-tables*




From ffjeld at common-lisp.net  Wed May  5 08:24:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 05 May 2004 04:24:32 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp 
Message-ID: <E1BLHhg-0000q9-00@common-lisp.net>

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

Modified Files:
	dp8390.lisp 
Log Message:
Changed the with-named-integers-syntax macro a bit, trying to make
this mechanism a bit more general and useful.

Date: Wed May  5 04:24:31 2004
Author: ffjeld

Index: movitz/losp/x86-pc/dp8390.lisp
diff -u movitz/losp/x86-pc/dp8390.lisp:1.6 movitz/losp/x86-pc/dp8390.lisp:1.7
--- movitz/losp/x86-pc/dp8390.lisp:1.6	Thu Feb 26 06:19:17 2004
+++ movitz/losp/x86-pc/dp8390.lisp	Wed May  5 04:24:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 18 12:21:36 2002
 ;;;;                
-;;;; $Id: dp8390.lisp,v 1.6 2004/02/26 11:19:17 ffjeld Exp $
+;;;; $Id: dp8390.lisp,v 1.7 2004/05/05 08:24:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,19 +22,20 @@
 (in-package muerte.x86-pc.ne2k)
 
 (defconstant +page0-read-map+
-    #(cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2))
+    '(:enum cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2))
 
 (defconstant +page0-write-map+
-    #(cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr))
+    '(:enum cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr))
 
 (defconstant +page1-read-map+
-    #(nil nil nil nil nil nil nil curr))
+    '(:enum nil nil nil nil nil nil nil curr))
 
 (defconstant +page1-write-map+
-    #(cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7))
+    '(:enum cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7))
 
 (defconstant +command-map+
-    '((#b001 . stop)
+    '(:rassoc
+      (#b001 . stop)
       (#b010 . start)
       (#b100 . transmit)
       (#o10  . remote-read)
@@ -47,7 +48,8 @@
       (#xc0  . page-3)))
 
 (defconstant +interrupt-status-map+
-    #(packet-received
+    '(:enum
+      packet-received
       packet-transmitted
       receive-error
       transmit-error
@@ -57,7 +59,8 @@
       reset-status))
 
 (defconstant +data-config-map+
-    '((#x01 . dma-16-bit)
+    '(:rassoc
+      (#x01 . dma-16-bit)
       (#x02 . big-endian)
       (#x04 . dma-address-32bit)
       (#x08 . loopback-off)
@@ -68,13 +71,15 @@
       (#x60 . fifo-threshold-12-bytes)))
 
 (defconstant +tx-config-map+
-    '((#x00 . loopback-mode-0)
+    '(:rassoc
+      (#x00 . loopback-mode-0)
       (#x02 . loopback-mode-1)
       (#x04 . loopback-mode-2)
       (#x06 . loopback-mode-3)))
 
 (defconstant +rx-config-map+
-    '((#x01 . save-error-packets)
+    '(:rassoc
+      (#x01 . save-error-packets)
       (#x02 . runt-packets)
       (#x04 . broadcast)
       (#x08 . multicast)
@@ -82,7 +87,7 @@
       (#x20 . monitor-mode)))
 
 (defconstant +command-bit-map+
-    #(stop start transmit))
+    '(:enum stop start transmit))
 
 ;;; Convenience syntax
 




From ffjeld at common-lisp.net  Wed May  5 08:24:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 05 May 2004 04:24:38 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <E1BLHhm-0000yY-00@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Changed the with-named-integers-syntax macro a bit, trying to make
this mechanism a bit more general and useful.

Date: Wed May  5 04:24:38 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.2 movitz/losp/x86-pc/pci.lisp:1.3
--- movitz/losp/x86-pc/pci.lisp:1.2	Fri Apr 23 11:04:17 2004
+++ movitz/losp/x86-pc/pci.lisp	Wed May  5 04:24:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.2 2004/04/23 15:04:17 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.3 2004/05/05 08:24:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,7 @@
 
 (provide :x86-pc/pci)
 
-(defun bios32-find ()
+(defun find-bios32 ()
   (loop for bios32 from #xe0000 to #xffff0 by 16
       if (and (= (memref-int bios32 0 0 :unsigned-byte16 t) #x335f)
 	      (= (memref-int bios32 0 1 :unsigned-byte16 t) #x5f32)




From ffjeld at common-lisp.net  Wed May  5 08:26:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 05 May 2004 04:26:15 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp 
Message-ID: <E1BLHjL-0002d6-00@common-lisp.net>

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

Modified Files:
	harddisk.lisp 
Log Message:
Checked in new version from Peter Minten.

Date: Wed May  5 04:26:14 2004
Author: ffjeld

Index: movitz/losp/tmp/harddisk.lisp
diff -u movitz/losp/tmp/harddisk.lisp:1.2 movitz/losp/tmp/harddisk.lisp:1.3
--- movitz/losp/tmp/harddisk.lisp:1.2	Sat Apr 24 11:13:26 2004
+++ movitz/losp/tmp/harddisk.lisp	Wed May  5 04:26:14 2004
@@ -1,264 +1,318 @@
-;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $
-
-(require :lib/named-integers)
-(provide :tmp/harddisk)
-
-(defpackage muerte.x86-pc.harddisk
-  (:use muerte.cl muerte muerte.lib muerte.x86-pc)
-  (:export make-512-vector
-           hd-read-sectors
-           hd-write-sectors
-           hd-commands
-	   ))
-
-(in-package muerte.x86-pc.harddisk)
-
-;;;
-;;; global variables
-;;;
-(defvar *hd-controllers* (vector (make-instance 'hd-controller))
-  "A vector of harddisk controllers.")
-
-;;;
-;;; constants
-;;;
-(defconstant +hd-default-first-irq+ 14)
-(defconstant +hd-default-second-irq+ 15)
-(defconstant +hd-default-first-command-base+ #x1F0)
-(defconstant +hd-default-second-command-base+ #x170)
-(defconstant +hd-default-first-control-base+ #x3F6)
-(defconstant +hd-default-second-control-base+ #x376)
-
-(define-named-integer hd-register-offset 
-    (:only-constants t)
-  (0 data)
-  (1 error)                            
-  (1 features)
-  (2 sector-count)
-  (3 lba-byte-1)                        ;bits 0-7
-  (4 lba-byte-2)                        ;bits 8-15
-  (5 lba-byte-3)                        ;bits 16-23
-  (6 lba-byte-4)                        ;bits 24-27
-  (7 status)
-  (7 command))
-
-(define-named-integer hd-commands
-    (:only-constants t)
-  (#x20 read-sectors-with-retry)
-  (#x30 write-sectors-with-retry))
-
-(define-named-integer hd-status-bits
-    (:only-constants t)
-  (0 error)
-  (1 index)
-  (2 corrected-data)
-  (3 data-request)
-  (4 drive-seek-complete)
-  (5 drive-write-fault)
-  (6 drive-ready)
-  (7 busy))
-
-;;;
-;;; classes
-;;;
-(defclass hd-controller ()
-  ((command-base :initform +hd-default-first-command-base+
-                 :initarg :command-base
-                 :type integer)
-   (control-base :initform +hd-default-first-control-base+
-                 :initarg :command-base
-                 :type integer)))
-
-;;;
-;;; waiters
-;;;
-(defun hd-controller-wait-for-drive-ready (hdc) ;wait for DRDY=1
-  (with-slots (control-base) hdc
-    (loop until (/= 0 (logand (io-port control-base :unsigned-byte8)
-                              #x40)))))  
-
-(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0
-  (with-slots (control-base) hdc
-    (loop until (= 0 (logand (io-port control-base :unsigned-byte8)
-                             #x80)))))
-
-(defun hd-controller-wait-for-data-request (hdc) ;wait for DRQ=1
-  (with-slots (control-base) hdc
-    (loop until (/= 0 (logand (io-port control-base :unsigned-byte8)
-                              #x08)))))
-
-;;;
-;;; feeders
-;;;
-(defun hd-controller-feed-lba-mode (hdc)
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-4)
-                 :unsigned-byte8)
-          (logior (io-port (hd-controller-command-register hdc 'lba-byte-4)
-                           :unsigned-byte8)
-                  #b01000000)))
-
-(defun hd-controller-feed-drive (hdc drive)
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-4)
-                 :unsigned-byte8)
-          (logior (* #b00010000 drive)
-                  (logand (io-port (hd-controller-command-register hdc 'lba-byte-4)
-                                   :unsigned-byte8)
-                          #b11101111))))
-
-(defun hd-controller-feed-lba-address (hdc lba)
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-1)
-                 :unsigned-byte8)
-          (logand lba #x000000FF))
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-2)
-                 :unsigned-byte8)
-          (logand lba #x0000FF00))
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-3)
-                               :unsigned-byte8)
-          (logand lba #x00FF0000))
-  (setf (io-port (hd-controller-command-register hdc 'lba-byte-3)
-                 :unsigned-byte8)
-          (logior (io-port (hd-controller-command-register hdc 'lba-byte-4)
-                           :unsigned-byte8)
-                  (logand lba #x000F0000))))
-
-;;;
-;;; misc
-;;;
-(defmacro while (test &body body)
-  `(do () ((not ,test))
-    , at body))
-
-(defun div (a b)
-  "Floored integer division, the painful way."
-  (let ((r 0)
-        (x a))
-    (while (>= x 0)
-      (decf x b)
-      (incf r))
-    (1- r)))
-
-(defun log2 (n)
-  (cond ((= n 256) 8)
-        ((= n 128) 7)
-        ((= n 64) 6)
-        ((= n 32) 5)
-        ((= n 16) 4)
-        ((= n 8) 3)
-        ((= n 4) 2)
-        ((= n 2) 1)
-        ((= n 1) 0)))
-        
-(defmacro with-hd-info ((hdc drive-number) hd-number &body body)
-  (let ((gs-hdnr (gensym "hd-number-")))
-    `(let* ((,gs-hdnr ,hd-number)
-            (,hdc (aref *hd-controllers* (div ,hd-number 2)))
-            (,drive-number (mod ,gs-hdnr 2)))
-      , at body)))
-
-(defun hd-controller-command-register (hdc name)
-  ;; use a case statement for now, until I learn how to use
-  ;; named-integer right
-  (+ (case name
-       ('data 0)
-       ('error 1)
-       ('features 1)
-       ('sector-count 2)
-       ('lba-byte-1 3)
-       ('lba-byte-2 4)
-       ('lba-byte-3 5)
-       ('lba-byte-4 6)
-       ('status 7)
-       ('command 7)
-       (else (error "HD command register not found ~A" name)))
-     (slot-value hdc 'command-base)))
-
-(defun error-code-meaning (code)
-  (nth (log2 code)
-       '("Address Mark Not Found"
-         "Track 0 Not Found"
-         "Media Change Requested"
-         "Aborted Command"
-         "ID Not Found"
-         "Media Changed"
-         "Uncorrectable Data Error"
-         "Bad Block Detected")))
-    
-    
-(defun hd-check-error (hdc command-name hdnr)
-  "Check and when found signal an error in task."
-  (when (/= 0 (logand (io-port (slot-value hdc 'control-base)
-                               :unsigned-byte8)
-                      #x01))
-    (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." 
-           command-name hdnr 
-           (error-code-meaning 
-            (io-port (hd-controller-command-register hdc 'error)
-                     :unsigned-byte8)))))
-
-;;;
-;;; hd operations
-;;;
-(defun hd-read-sectors (hdnr start-sector count)
-  (let ((data (make-array 512 :element-type :unsigned-byte8))
-        (offset 0)
-        (read-data nil))
-    (with-hd-info (hdc drive) hdnr
-      ;; set drive
-      (hd-controller-feed-drive hdc drive)
-      ;; set count
-      (setf (io-port (hd-controller-command-register hdc 'sector-count)
-                     :unsigned-byte8)
-              count)
-      ;; set LBA and address
-      (hd-controller-feed-lba-mode hdc)
-      (hd-controller-feed-lba-address hdc start-sector)
-      ;; get going
-      (setf (io-port (hd-controller-command-register hdc 'command)
-                     :unsigned-byte8)
-              +hd-commands-read-sectors-with-retry+)
-      ;; data handling
-      (while (<= offset (* count 512))
-        (hd-controller-wait-for-drive-ready hdc)
-        (hd-controller-wait-for-ready hdc)
-        (hd-check-error hdc "read-sectors" hdnr)
-        (hd-controller-wait-for-data-request hdc)
-        (dotimes (i 256)
-          (setf read-data (io-port (hd-controller-command-register hdc 'status)
-                                   :unsigned-byte16)))
-          (setf (aref data offset) (logand read-data #xFF))
-          (setf (aref data (1+ offset)) (logand read-data #xFF00))              
-          (incf offset 2))
-      ;; done
-      data)))
-
-(defun hd-write-sectors (hdnr start-sector data)
-  (let ((offset 0)
-        (write-data nil)
-        (count (div (length data) 512)))
-    (with-hd-info (hdc drive) hdnr
-      ;; set drive
-      (hd-controller-feed-drive hdc drive)
-      ;; set count
-      (setf (io-port (hd-controller-command-register hdc 'sector-count)
-                     :unsigned-byte8)
-              count)
-      ;; set LBA and address
-      (hd-controller-feed-lba-mode hdc)
-      (hd-controller-feed-lba-address hdc start-sector)
-      ;; get going
-      (setf (io-port (hd-controller-command-register hdc 'command)
-                     :unsigned-byte8)
-              +hd-commands-write-sectors-with-retry+)
-      ;; data handling
-      (while (<= offset (* count 512))
-        (hd-controller-wait-for-drive-ready hdc)
-        (hd-controller-wait-for-ready hdc)
-        (hd-check-error hdc "write-sectors" hdnr)
-        (hd-controller-wait-for-data-request hdc)
-        (dotimes (i 256)
-          (setf write-data (aref data offset))
-          (incf write-data (* #xFF (aref data (1+ offset))))
-          (setf (io-port (hd-controller-command-register hdc 'data)
-                         :unsigned-byte16)
-                  write-data)
-          (incf offset 2))))))
\ No newline at end of file
+;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $
+
+(require :lib/named-integers)
+
+(provide :tmp/harddisk)
+
+(defpackage muerte.x86-pc.harddisk
+  (:use muerte.cl muerte muerte.lib muerte.x86-pc)
+  (:export hdc-reset
+           hd-read-sectors
+           hd-write-sectors))
+
+(in-package muerte.x86-pc.harddisk)
+
+;;;
+;;; global variables
+;;;
+(defvar *hd-controllers* (vector (make-instance 'hd-controller))
+  "A vector of harddisk controllers.")
+
+;;;
+;;; constants
+;;;
+(defconstant +hd-default-first-irq+ 14)
+(defconstant +hd-default-second-irq+ 15)
+(defconstant +hd-default-first-command-base+ #x1F0)
+(defconstant +hd-default-second-command-base+ #x170)
+(defconstant +hd-default-first-control-base+ #x3F6)
+(defconstant +hd-default-second-control-base+ #x376)
+
+;;;
+;;; classes
+;;;
+(defclass hd-controller ()
+  ((command-base :initform +hd-default-first-command-base+
+                 :initarg :command-base
+                 :type integer)
+   (control-base :initform +hd-default-first-control-base+
+                 :initarg :command-base
+                 :type integer)))
+;;;
+;;; accessors
+;;;
+
+(defmacro data-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 0) :unsigned-byte16))
+
+(defmacro features-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8))
+
+(defmacro error-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8))
+
+(defmacro sector-count-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 2) :unsigned-byte8))
+
+(defmacro lba-low-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 3) :unsigned-byte8))
+
+(defmacro lba-mid-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 4) :unsigned-byte8))
+
+(defmacro lba-high-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 5) :unsigned-byte8))
+
+(defmacro device-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 6) :unsigned-byte8))
+
+(defmacro command-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8))
+
+(defmacro status-register (hdc)
+  `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8))
+
+(defmacro alt-status-register (hdc)
+  `(io-port (slot-value ,hdc 'control-base) :unsigned-byte8))
+
+;;;
+;;; getters
+;;;
+(defun reg-bsy (hdc)
+  (get-bit 7 (status-register hdc)))
+
+(defun reg-drdy (hdc)
+  (get-bit 6 (status-register hdc)))
+
+(defun reg-drq (hdc)
+  (get-bit 3 (status-register hdc)))
+
+(defun reg-err (hdc)
+  (get-bit 0 (status-register hdc)))
+
+(defun reg-alt-bsy (hdc)
+  (get-bit 7 (alt-status-register hdc)))
+
+(defun reg-alt-drdy (hdc)
+  (get-bit 6 (alt-status-register hdc)))
+
+(defun reg-alt-drq (hdc)
+  (get-bit 3 (alt-status-register hdc)))
+
+(defun reg-alt-err (hdc)
+  (get-bit 3 (alt-status-register hdc)))
+
+;;;
+;;; setters
+;;;
+(defun set-drive-number (hdc drive)
+  (set-bit 4 (/= drive 0) (device-register hdc)))
+
+(defun set-intrq-mode (hdc mode)
+  (set-bit 1 (not mode) (device-register hdc)))
+
+(defun set-lba-mode (hdc mode)
+  (set-bit 6 mode (device-register hdc)))
+
+(defun set-lba-address (hdc lba)
+  (setf (lba-low-register hdc) (ldb (byte 8 0) lba))
+  (setf (lba-mid-register hdc) (ldb (byte 8 8) lba))
+  (setf (lba-high-register hdc) (ldb (byte 8 16) lba))
+  (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24)
+                                   (byte 4 0)
+                                   (device-register hdc))))
+
+(defun set-sector-count (hdc count)
+  (setf (sector-count-register hdc) count))
+
+(defun set-command (hdc command)
+  (let ((command-code (case command
+                        ('read-sectors-with-retry #x20)
+                        ('write-sectors-with-retry #x30)
+                        ('identify-drive #xCE))))
+  (setf (command-register hdc) command-code)))
+          
+;;;
+;;; misc
+;;;
+(defun get-bit (number place)
+  (/= 0 (ldb (byte 1 number) place)))
+
+(defmacro set-bit (number value place)
+  (let ((gs-number (gensym "number-")))
+    `(if ,value
+      (let ((,gs-number ,number))
+        (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place)))
+      (setf ,place (dpb 0 (byte 1 ,number) ,place)))))
+
+(defmacro while (test &body body)
+  `(do () ((not ,test))
+    , at body))
+
+(defun log2 (n)
+  (cond ((= n 256) 8)
+        ((= n 128) 7)
+        ((= n 64) 6)
+        ((= n 32) 5)
+        ((= n 16) 4)
+        ((= n 8) 3)
+        ((= n 4) 2)
+        ((= n 2) 1)
+        ((= n 1) 0)))
+  
+(defmacro with-hd-info ((hdc drive-number) hd-number &body body)
+  (let ((gs-hdnr (gensym "hd-number-")))
+    `(let* ((,gs-hdnr ,hd-number)
+            (,hdc (aref *hd-controllers* (truncate ,hd-number 2)))
+            (,drive-number (mod ,gs-hdnr 2)))
+      , at body)))
+
+(defun error-code-meaning (code)
+  (if (< 0 code 257)
+      (nth (log2 code)
+           '("Address Mark Not Found"
+             "Track 0 Not Found"
+             "Media Change Requested"
+             "Aborted Command"
+             "ID Not Found"
+             "Media Changed"
+             "Uncorrectable Data Error"
+             "Bad Block Detected"))
+      "No error"))
+    
+(defun hdc-error (hdc command-name hdnr)
+  (puts "In HDC error")
+  (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." 
+         command-name hdnr 
+         (error-code-meaning 
+          (io-port (error-register hdc) :unsigned-byte8))))
+
+(defun puts (s)
+  (fresh-line)
+  (format t s)
+  (terpri))
+
+;;;
+;;; hd operations
+;;;
+(defun hdc-reset (hdcnr)
+  "Reset the harddisk controller. Must be done at startup to
+initialize the harddisk controller."
+  ;; set SRST
+  ;; wait > 2ms
+  ;; continue when BSY=0
+  (let ((hdc (aref *hd-controllers* hdcnr)))
+    (setf (device-register hdc) #x04)
+    (loop for x from 1 to 2500)
+    (loop while (reg-bsy hdc))))
+
+(defun hd-read-sectors (hdnr start-sector count)
+  (let ((data (make-array (* count 512) :element-type :unsigned-byte8))
+        (offset 0)
+        input)
+    (with-hd-info (hdc drive) hdnr
+      (tagbody
+;        (puts "in entry")
+        ;; drive must be ready
+        ;; drive number must be set
+        ;; intrq's must not be used
+        ;; LBA mode must be on
+        ;; LBA must be set
+        ;; sector-count must be set
+        ;; command must be entered
+        ;; 400 nsec must be waited before checking BSY
+        (loop until (reg-drdy hdc))
+        (loop while (reg-alt-bsy hdc))
+        (set-drive-number hdc drive)
+        (set-intrq-mode hdc nil)
+        (set-lba-mode hdc t)
+        (set-lba-address hdc start-sector)
+        (set-sector-count hdc count)
+        (set-command hdc 'read-sectors-with-retry)
+        (dotimes (x 500))              ;aught to be enough waiting
+        (go :check-status)
+        ;;;;;;;;;;;;;;;;;;
+        :check-status
+;        (puts "in check-status")
+        ;; if BSY=0 and DRQ=0 then error
+        ;; if BSY=0 and DRQ=1 then go transfer-data
+        ;; if BSY=1 then go check-state
+        (let ((status (status-register hdc)))
+          (if (get-bit 7 status)       ;if BSY = 1
+              (go :check-status)
+              (if (get-bit 3 status)   ;if DRQ = 1
+                  (go :transfer-data)
+                  (progn
+                    (hdc-error hdc "read-sectors" hdnr)))))
+        ;;;;;;;;;;;;;;;;;;
+        :transfer-data
+;        (puts "in transfer-data")        
+        ;; read the data register
+        (setf input (data-register hdc))
+        (setf (aref data offset) (ldb (byte 8 0) input))
+        (incf offset)
+        (setf (aref data offset) (ldb (byte 8 8) input))
+        (incf offset)
+        ;; read the status register to determine if we're done
+        (if (reg-drq hdc)
+            (if (/= 0 (mod offset 512))
+                (go :transfer-data)     ;data block not completely transfered
+                (progn
+                  (alt-status-register hdc) ;read and ignore
+                  (go :check-status)))
+            (return-from hd-read-sectors data))))))
+
+(defun hd-write-sectors (hdnr start-sector data)
+  (check-type hdnr (integer 0 *))
+  (check-type start-sector (integer 0 *))
+  (check-type data vector)
+  (let ((count (truncate (length data) 512))
+        (offset 0))
+    (with-hd-info (hdc drive) hdnr
+      (tagbody
+;        (puts "in entry")
+        ;; drive must be ready
+        ;; drive number must be set
+        ;; intrq's must not be used
+        ;; LBA mode must be on
+        ;; LBA must be set
+        ;; sector-count must be set
+        ;; command must be entered
+        ;; 400 nsec must be waited before checking BSY
+        (loop until (reg-drdy hdc))
+        (loop while (reg-alt-bsy hdc))
+        (set-drive-number hdc drive)
+        (set-intrq-mode hdc nil)
+        (set-lba-mode hdc t)
+        (set-lba-address hdc start-sector)
+        (set-sector-count hdc count)
+        (set-command hdc 'write-sectors-with-retry)
+        (dotimes (x 500))              ;aught to be enough waiting
+        (go :check-status)
+        ;;;;;;;;;;;;;;;;;;
+        :check-status
+;        (puts "in check-status")
+        ;; if BSY=0 and DRQ=0 then error
+        ;; if BSY=0 and DRQ=1 then go transfer-data
+        ;; if BSY=1 then go 
+        (let ((status (status-register hdc)))
+          (if (get-bit 7 status)       ;if BSY = 1
+              (go :check-status)
+              (if (get-bit 3 status)   ;if DRQ = 1
+                  (go :transfer-data)
+                  (hdc-error hdc "write-sectors" hdnr))))
+        ;;;;;;;;;;;;;;;;;;
+        :transfer-data
+;        (puts "in transfer-data")
+        ;; read the data register
+        (setf (data-register hdc) (+ (aref data offset)
+                                     (ash (aref data (1+ offset)) 8)))
+        (incf offset 2)
+        ;; read the status register to determine if we're done
+        (if (reg-drq hdc)
+            (if (/= 0 (mod offset 512))
+                (go :transfer-data)     ;data block not completely transfered
+                (progn
+                  (alt-status-register hdc) ;read and ignore
+                  (go :check-status)))
+	  (return-from hd-write-sectors nil))))))




From ffjeld at common-lisp.net  Tue May 11 15:05:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 11 May 2004 11:05:30 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp 
Message-ID: <E1BNYoz-00014b-00@common-lisp.net>

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

Modified Files:
	harddisk.lisp 
Log Message:
Updates from Peter Minten.

Date: Tue May 11 11:05:28 2004
Author: ffjeld

Index: movitz/losp/tmp/harddisk.lisp
diff -u movitz/losp/tmp/harddisk.lisp:1.3 movitz/losp/tmp/harddisk.lisp:1.4
--- movitz/losp/tmp/harddisk.lisp:1.3	Wed May  5 04:26:14 2004
+++ movitz/losp/tmp/harddisk.lisp	Tue May 11 11:05:25 2004
@@ -1,4 +1,4 @@
-;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $
+;;;; $Id: harddisk.lisp,v 1.4 2004/05/11 15:05:25 ffjeld Exp $
 
 (require :lib/named-integers)
 
@@ -7,6 +7,7 @@
 (defpackage muerte.x86-pc.harddisk
   (:use muerte.cl muerte muerte.lib muerte.x86-pc)
   (:export hdc-reset
+           hd-identify-device
            hd-read-sectors
            hd-write-sectors))
 
@@ -118,19 +119,35 @@
   (setf (lba-low-register hdc) (ldb (byte 8 0) lba))
   (setf (lba-mid-register hdc) (ldb (byte 8 8) lba))
   (setf (lba-high-register hdc) (ldb (byte 8 16) lba))
-  (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24)
+  (setf (device-register hdc) (dpb (ldb (byte 4 24) lba)
                                    (byte 4 0)
                                    (device-register hdc))))
 
+(defun set-lba-address-ext (hdc lba)
+  (setf (lba-low-register hdc) (ldb (byte 8 0) lba))
+  (setf (lba-mid-register hdc) (ldb (byte 8 8) lba))
+  (setf (lba-high-register hdc) (ldb (byte 8 16) lba))
+
+  ;; movitz byte function has a restriction, the location must be <= 30
+  ;; therefore this workaround
+  (setf (lba-low-register hdc) (ldb (byte 8 0) (ash lba -24)))
+  (setf (lba-mid-register hdc) (ldb (byte 8 8) (ash lba -24)))
+  (setf (lba-high-register hdc) (ldb (byte 8 16) (ash lba -24))))
+
 (defun set-sector-count (hdc count)
   (setf (sector-count-register hdc) count))
 
+(defun set-sector-count-ext (hdc count)
+  (setf (sector-count-register hdc) (ldb (byte 8 0) count))
+  (setf (sector-count-register hdc) (ldb (byte 8 8) count)))
+
 (defun set-command (hdc command)
-  (let ((command-code (case command
-                        ('read-sectors-with-retry #x20)
-                        ('write-sectors-with-retry #x30)
-                        ('identify-drive #xCE))))
-  (setf (command-register hdc) command-code)))
+  (setf (command-register hdc) (case command
+                                 ('identify-drive #xEC)
+                                 ('read-sectors #x20)
+                                 ('read-sectors-ext #x24)
+                                 ('write-sectors #x30)
+                                 ('write-sectors-ext #x34))))
           
 ;;;
 ;;; misc
@@ -139,11 +156,7 @@
   (/= 0 (ldb (byte 1 number) place)))
 
 (defmacro set-bit (number value place)
-  (let ((gs-number (gensym "number-")))
-    `(if ,value
-      (let ((,gs-number ,number))
-        (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place)))
-      (setf ,place (dpb 0 (byte 1 ,number) ,place)))))
+  `(setf ,place (dpb (if ,value 1 0) (byte 1 ,number) ,place)))
 
 (defmacro while (test &body body)
   `(do () ((not ,test))
@@ -206,9 +219,57 @@
     (loop for x from 1 to 2500)
     (loop while (reg-bsy hdc))))
 
+(defun hd-identify-device (hdnr)
+  "Get device information of hdnr. Returns a (vector 256 (unsigned-byte 16))."
+  (let ((data (make-array 256 :element-type :unsigned-byte16))
+        (offset 0))
+    (with-hd-info (hdc drive) hdnr
+      (tagbody
+        ;; drive must be ready
+        ;; drive number must be set
+        ;; intrq's must not be used
+        ;; LBA mode must be on
+        ;; LBA must be set
+        ;; sector-count must be set
+        ;; command must be entered
+        ;; 400 nsec must be waited before checking BSY
+        (loop until (reg-drdy hdc))
+        (loop while (reg-alt-bsy hdc))
+        (set-drive-number hdc drive)
+        (set-intrq-mode hdc nil)
+        (set-command hdc 'identify-drive)
+        (dotimes (x 500))              ;aught to be enough waiting
+        (go :check-status)
+        ;;;;;;;;;;;;;;;;;;
+        :check-status
+        ;; if BSY=0 and DRQ=0 then error
+        ;; if BSY=0 and DRQ=1 then go transfer-data
+        ;; if BSY=1 then go check-state
+        (let ((status (status-register hdc)))
+          (if (get-bit 7 status)       ;if BSY = 1
+              (go :check-status)
+              (if (get-bit 3 status)   ;if DRQ = 1
+                  (go :transfer-data)
+                  (progn
+                    (hdc-error hdc "identify-device" hdnr)))))
+        ;;;;;;;;;;;;;;;;;;
+        :transfer-data
+        ;; read the data register
+        (setf (aref data offset) (data-register hdc))
+        (incf offset)
+        ;; read the status register to determine if we're done
+        (if (reg-drq hdc)
+            (if (< offset 256)
+                (go :transfer-data)     ;data block not completely transfered
+                (go :check-status))
+            (return-from hd-identify-device data))))))
+
 (defun hd-read-sectors (hdnr start-sector count)
+  "Read count sectors from hdnr, starting at start-sector. Returns a (vector (* count 512) (unsigned-byte 8)). If start-sector doesn't fit into 28 bits or count doesn't fit into 8 bits an attempt is made to use 48 bits addressing."
   (let ((data (make-array (* count 512) :element-type :unsigned-byte8))
         (offset 0)
+        (ext-mode (or (>= start-sector #xFFFFFFF)
+                      (>= count #xFF)))
         input)
     (with-hd-info (hdc drive) hdnr
       (tagbody
@@ -226,9 +287,20 @@
         (set-drive-number hdc drive)
         (set-intrq-mode hdc nil)
         (set-lba-mode hdc t)
+        (if ext-mode
+           (progn
+             (puts "using 48 bits addressing")
+             (set-lba-address-ext hdc start-sector)
+             (set-sector-count-ext hdc count)
+             (set-command hdc 'read-sectors-ext))
+           (progn
+             (puts "using 28 bits addressing")
+             (set-lba-address hdc start-sector)
+             (set-sector-count hdc count)
+             (set-command hdc 'read-sectors)))
         (set-lba-address hdc start-sector)
         (set-sector-count hdc count)
-        (set-command hdc 'read-sectors-with-retry)
+        (set-command hdc 'read-sectors)
         (dotimes (x 500))              ;aught to be enough waiting
         (go :check-status)
         ;;;;;;;;;;;;;;;;;;
@@ -266,8 +338,10 @@
   (check-type hdnr (integer 0 *))
   (check-type start-sector (integer 0 *))
   (check-type data vector)
-  (let ((count (truncate (length data) 512))
-        (offset 0))
+  (let* ((count (truncate (length data) 512))
+         (ext-mode (or (>= start-sector #xFFFFFFF)
+                       (>= count #xFF)))
+         (offset 0))
     (with-hd-info (hdc drive) hdnr
       (tagbody
 ;        (puts "in entry")
@@ -284,9 +358,20 @@
         (set-drive-number hdc drive)
         (set-intrq-mode hdc nil)
         (set-lba-mode hdc t)
+        (if ext-mode                    
+            (progn
+              (puts "using 48 bits addressing")
+              (set-lba-address-ext hdc start-sector)
+              (set-sector-count-ext hdc count)
+              (set-command hdc 'write-sectors-ext))
+            (progn
+              (puts "using 28 bits addressing")
+              (set-lba-address hdc start-sector)
+              (set-sector-count hdc count)
+              (set-command hdc 'write-sectors)))
         (set-lba-address hdc start-sector)
         (set-sector-count hdc count)
-        (set-command hdc 'write-sectors-with-retry)
+        (set-command hdc 'write-sectors)
         (dotimes (x 500))              ;aught to be enough waiting
         (go :check-status)
         ;;;;;;;;;;;;;;;;;;
@@ -315,4 +400,4 @@
                 (progn
                   (alt-status-register hdc) ;read and ignore
                   (go :check-status)))
-	  (return-from hd-write-sectors nil))))))
+            (return-from hd-write-sectors nil))))))
\ No newline at end of file




From ffjeld at common-lisp.net  Wed May 19 14:56:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 10:56:46 -0400
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <E1BQSUw-0006PB-00@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
Don't check for movitz-package in movitz-compile-file.

Date: Wed May 19 10:56:46 2004
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.3 movitz/movitz-mode.el:1.4
--- movitz/movitz-mode.el:1.3	Mon Feb  2 08:31:23 2004
+++ movitz/movitz-mode.el	Wed May 19 10:56:46 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 18:12:17 2001
 ;;;;                
-;;;; $Id: movitz-mode.el,v 1.3 2004/02/02 13:31:23 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -113,12 +113,11 @@
 
 (defun movitz-compile-file ()
   (interactive)
-  (when (in-movitz-package-p)
-    (save-some-buffers)
-    (message "Movitz compiling \"%s\"..." (buffer-file-name))
-    (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name))
-    (message "Movitz compiling \"%s\"...done."
-	     (buffer-file-name))))
+  (save-some-buffers)
+  (message "Movitz compiling \"%s\"..." (buffer-file-name))
+  (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name))
+  (message "Movitz compiling \"%s\"...done."
+	   (buffer-file-name)))
 
 (defun movitz-eval-in-acl (string msg)
   (fi::note-background-request nil)
@@ -284,6 +283,11 @@
 	    (when (in-movitz-package-p)
 	      (message "Switching to Movitz keymap.")
 	      (use-local-map (make-movitz-common-lisp-mode-map)))))
+
+(defun movitz-mode ()
+  "Switch on Movitz-mode."
+  (interactive)
+  (use-local-map (make-movitz-common-lisp-mode-map)))
 
 (let ((tag 'fi:common-lisp-indent-hook))
   (put 'compiler-values tag '(like with-open-file))




From ffjeld at common-lisp.net  Wed May 19 14:57:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 10:57:46 -0400
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <E1BQSVu-00076R-00@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
File-header edits.

Date: Wed May 19 10:57:46 2004
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.4 movitz/movitz-mode.el:1.5
--- movitz/movitz-mode.el:1.4	Wed May 19 10:56:46 2004
+++ movitz/movitz-mode.el	Wed May 19 10:57:46 2004
@@ -1,16 +1,16 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 
-;;;;    Department of Computer Science, University of Troms?, Norway.
+;;;;    Copyright (C) 2001, 2004
+;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
 ;;;; 
 ;;;; Filename:      movitz-mode.el
-;;;; Description:   
+;;;; Description:   Modifies Franz' ELI slightly to integrate with Movitz.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 18:12:17 2001
 ;;;;                
-;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.5 2004/05/19 14:57:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 




From ffjeld at common-lisp.net  Wed May 19 14:59:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 10:59:53 -0400
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BQSXx-00035o-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added a small check for the package-name when dumping packages, so as
not to blindly dump packages that are native to the host system should
a symbol in such a package accidentally be referenced.

Date: Wed May 19 10:59:53 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.27 movitz/image.lisp:1.28
--- movitz/image.lisp:1.27	Wed Apr 21 11:06:50 2004
+++ movitz/image.lisp	Wed May 19 10:59: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.27 2004/04/21 15:06:50 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.28 2004/05/19 14:59:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1065,6 +1065,12 @@
 				  name symbol)
 		   name)))
 	     (ensure-package (package-name lisp-package)
+	       (assert (not (member (package-name lisp-package)
+				    #+allegro '(excl common-lisp sys aclmop)
+				    #-allegro '(common-lisp)
+				    :test #'string=)) ()
+		 "I don't think you really want to dump the package ~A with Movitz."
+		 lisp-package)
 	       (setf (gethash lisp-package lisp-to-movitz-package)
 		 (or (gethash package-name packages-hash nil)
 		     (let ((p (funcall 'muerte::make-package-object




From ffjeld at common-lisp.net  Wed May 19 15:02:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 11:02:50 -0400
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/los-closette-compiler.lisp 
Message-ID: <E1BQSao-00019Y-00@common-lisp.net>

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

Modified Files:
	los-closette-compiler.lisp 
Log Message:
Accept (but ignore) the :documentation class option.

Date: Wed May 19 11:02:50 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette-compiler.lisp
diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.12 movitz/losp/muerte/los-closette-compiler.lisp:1.13
--- movitz/losp/muerte/los-closette-compiler.lisp:1.12	Mon Apr 19 18:38:22 2004
+++ movitz/losp/muerte/los-closette-compiler.lisp	Wed May 19 11:02:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 29 13:15:11 2002
 ;;;;                
-;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -674,8 +674,9 @@
       (apply #'initialize-class-object class all-keys)))
   
   (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots
-						      default-initargs-function)
-    (declare (ignore metaclass))
+						      default-initargs-function
+						      documentation)
+    (declare (ignore metaclass documentation))
     (let ((class (std-allocate-instance *the-class-standard-class*)))
       (setf (movitz-class-name class) name)
       (setf (class-direct-subclasses class) ())




From ffjeld at common-lisp.net  Wed May 19 15:09:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 11:09:09 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BQSgv-0007x4-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added gcd, mainly borrowed from cmucl.

Date: Wed May 19 11:09:07 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.8 movitz/losp/muerte/integers.lisp:1.9
--- movitz/losp/muerte/integers.lisp:1.8	Fri Apr 23 09:02:22 2004
+++ movitz/losp/muerte/integers.lisp	Wed May 19 11:09: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.8 2004/04/23 13:02:22 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1103,3 +1103,32 @@
 (defun minus-if (x y)
   (if (integerp x) (- x y) x))
 
+(defun gcd (&rest numbers)
+  (numargs-case
+   (1 (u) u)
+   (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))
+	   (do ((temp (if (oddp u) (- v) (ash u -1))
+		      (ash temp -1)))
+	       (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))))))))
+   (t (&rest numbers)
+      (declare (dynamic-extent numbers))
+      (do ((gcd (car numbers)
+		(gcd gcd (car rest)))
+	   (rest (cdr numbers) (cdr rest)))
+	  ((null rest) gcd)))))




From ffjeld at common-lisp.net  Wed May 19 15:42:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 19 May 2004 11:42:08 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BQTCq-0000cC-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added floor.

Date: Wed May 19 11:42:08 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.9 movitz/losp/muerte/integers.lisp:1.10
--- movitz/losp/muerte/integers.lisp:1.9	Wed May 19 11:09:05 2004
+++ movitz/losp/muerte/integers.lisp	Wed May 19 11:42: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.9 2004/05/19 15:09:05 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.10 2004/05/19 15:42:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1132,3 +1132,19 @@
 		(gcd gcd (car rest)))
 	   (rest (cdr numbers) (cdr rest)))
 	  ((null rest) gcd)))))
+
+(defun floor (n &optional (divisor 1))
+  "This is floor written in terms of truncate."
+  (numargs-case
+   (1 (n) 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))))))
+   (t (n &optional (divisor 1))
+      (floor n divisor))))
\ No newline at end of file




From ffjeld at common-lisp.net  Thu May 20 17:41:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 13:41:47 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BQrYB-00065o-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
A slightly improved vector-push-extend.

Date: Thu May 20 13:41:46 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.18 movitz/losp/muerte/arrays.lisp:1.19
--- movitz/losp/muerte/arrays.lisp:1.18	Fri Apr 23 10:59:55 2004
+++ movitz/losp/muerte/arrays.lisp	Thu May 20 13:41:46 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.18 2004/04/23 14:59:55 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.19 2004/05/20 17:41:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -611,7 +611,16 @@
 
 (defun vector-push-extend (new-element vector &optional extension)
   (declare (ignore extension))
-  (vector-push new-element vector))
+  (check-type vector vector)
+  (let ((p (vector-fill-pointer vector)))
+    (declare (type (unsigned-byte 16) p))
+    (cond
+     ((< p (vector-dimension vector))
+      (setf (aref vector p) new-element
+	    (fill-pointer vector) (1+ p)))
+     (t (error "Vector-push extending not implemented yet.")))
+    p))
+
 
 (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env)
   (let ((actual-index (and (movitz:movitz-constantp index env)




From ffjeld at common-lisp.net  Thu May 20 17:43:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 13:43:47 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BQra7-0008JM-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Make defpackage :use list translate the common-lisp package to the
muerte.common-lisp package, so as to better support movitz-compiling
the same code as normal.

Date: Thu May 20 13:43:47 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.17 movitz/losp/muerte/basic-macros.lisp:1.18
--- movitz/losp/muerte/basic-macros.lisp:1.17	Mon Apr 19 11:06:26 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu May 20 13:43: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.17 2004/04/19 15:06:26 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.18 2004/05/20 17:43:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,12 +65,19 @@
 (defmacro defpackage (package-name &rest options)
   (pushnew '(:use) options :key #'car)
   (let ((uses (cdr (assoc :use options))))
+    (setf uses (mapcar (lambda (use)
+			 (if (member use '(:cl :common-lisp) :test #'string=)
+			     :muerte.cl
+			   use))
+		       uses))
     (when (or (null uses)
 	      (member :muerte.cl uses :test #'string=)
 	      (member :muerte.common-lisp uses :test #'string=))
-      (push '(:shadowing-import-from :common-lisp nil) options)))
-  `(eval-when (:compile-toplevel)
-     (defpackage ,package-name , at options)))
+      (push '(:shadowing-import-from :common-lisp nil) options))
+    (let ((movitz-options (cons (cons :use uses)
+				(remove :use options :key #'car))))
+      `(eval-when (:compile-toplevel)
+	 (defpackage ,package-name , at movitz-options)))))
 
 (defmacro cond (&rest clauses)
   (if (null clauses)




From ffjeld at common-lisp.net  Thu May 20 17:47:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 13:47:24 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1BQrdc-0000nu-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
For (format nil ...) make initial output string somewhat longer.

Date: Thu May 20 13:47:24 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.4 movitz/losp/muerte/format.lisp:1.5
--- movitz/losp/muerte/format.lisp:1.4	Tue Apr 13 10:21:57 2004
+++ movitz/losp/muerte/format.lisp	Thu May 20 13:47:24 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.4 2004/04/13 14:21:57 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.5 2004/05/20 17:47:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,7 +30,7 @@
   (declare (dynamic-extent args))
   (let ((destination
 	 (case destination
-	   ((nil) (make-array (* 2 (length control))
+	   ((nil) (make-array (* 3 (length control))
 			      :element-type 'character
 			      :fill-pointer 0))
 	   ((t) *standard-output*)




From ffjeld at common-lisp.net  Thu May 20 17:48:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 13:48:04 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <E1BQreG-0001Nr-00@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Added a simple position-if-not.

Date: Thu May 20 13:48:04 2004
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.7 movitz/losp/muerte/sequences.lisp:1.8
--- movitz/losp/muerte/sequences.lisp:1.7	Fri Apr 23 11:02:20 2004
+++ movitz/losp/muerte/sequences.lisp	Thu May 20 13:48:04 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.7 2004/04/23 15:02:20 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.8 2004/05/20 17:48:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -290,6 +290,9 @@
 			       (let ((next-i (position-if predicate p :key key :from-end t)))
 				 (if next-i (+ i 1 next-i) i)))))))))))))))
 
+(defun position-if-not (predicate sequence &rest key-args)
+  (declare (dynamic-extent key-args))
+  (apply #'position-if (complement predicate) sequence key-args))
 
 (defun nreverse (sequence)
   (sequence-dispatch sequence




From ffjeld at common-lisp.net  Thu May 20 17:48:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 13:48:34 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp 
Message-ID: <E1BQrek-0004sy-00@common-lisp.net>

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

Modified Files:
	simple-streams.lisp 
Log Message:
Use vector-push-extend rather than vector-push when write-char to a string.

Date: Thu May 20 13:48:34 2004
Author: ffjeld

Index: movitz/losp/muerte/simple-streams.lisp
diff -u movitz/losp/muerte/simple-streams.lisp:1.4 movitz/losp/muerte/simple-streams.lisp:1.5
--- movitz/losp/muerte/simple-streams.lisp:1.4	Wed Feb 18 09:39:37 2004
+++ movitz/losp/muerte/simple-streams.lisp	Thu May 20 13:48:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 29 13:39:43 2003
 ;;;;                
-;;;; $Id: simple-streams.lisp,v 1.4 2004/02/18 14:39:37 ffjeld Exp $
+;;;; $Id: simple-streams.lisp,v 1.5 2004/05/20 17:48:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -427,7 +427,7 @@
        (%check stream :output)
        (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
     (string
-     (vector-push character stream))))
+     (vector-push-extend character stream))))
 
 (defun %read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))




From ffjeld at common-lisp.net  Thu May 20 18:13:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 14:13:55 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/streams.lisp 
Message-ID: <E1BQs3H-00044P-00@common-lisp.net>

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

Modified Files:
	streams.lisp 
Log Message:
Also here prefer vector-push-extend over vector-push.

Date: Thu May 20 14:13:55 2004
Author: ffjeld

Index: movitz/losp/muerte/streams.lisp
diff -u movitz/losp/muerte/streams.lisp:1.2 movitz/losp/muerte/streams.lisp:1.3
--- movitz/losp/muerte/streams.lisp:1.2	Mon Jan 19 06:23:47 2004
+++ movitz/losp/muerte/streams.lisp	Thu May 20 14:13:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Jun 30 14:33:15 2003
 ;;;;                
-;;;; $Id: streams.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: streams.lisp,v 1.3 2004/05/20 18:13:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -24,7 +24,7 @@
   (:no-clos-fallback stream-no-clos))
 
 (defmethod stream-write-char ((stream string) character)
-  (vector-push character stream)
+  (vector-push-extend character stream)
   character)
 
 (defmethod stream-write-char ((stream function) character)
@@ -100,10 +100,10 @@
     (string
      (case (funobj-name *forward-generic-function*)
        (stream-write-char
-	(vector-push (car args) stream)
+	(vector-push-extend (car args) stream)
 	(car args))
        (stream-fresh-line
-	(vector-push #\newline stream)
+	(vector-push-extend #\newline stream)
 	t)))
     (function
      (apply stream (funobj-name *forward-generic-function*) args))))




From ffjeld at common-lisp.net  Thu May 20 18:16:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 14:16:13 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp 
Message-ID: <E1BQs5V-0005eT-00@common-lisp.net>

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

Modified Files:
	serial.lisp 
Log Message:
Header update.

Date: Thu May 20 14:16:13 2004
Author: ffjeld

Index: movitz/losp/x86-pc/serial.lisp
diff -u movitz/losp/x86-pc/serial.lisp:1.1.1.1 movitz/losp/x86-pc/serial.lisp:1.2
--- movitz/losp/x86-pc/serial.lisp:1.1.1.1	Tue Jan 13 06:05:06 2004
+++ movitz/losp/x86-pc/serial.lisp	Thu May 20 14:16:13 2004
@@ -1,16 +1,16 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
 ;;;;    Copyright (C) 2001-2004, 
-;;;;    Department of Computer Science, University of Troms??, Norway.
+;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
 ;;;; 
 ;;;; Filename:      serial.lisp
-;;;; Description:   
+;;;; Description:   Serial port interfacing.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 11 14:42:12 2002
 ;;;;                
-;;;; $Id: serial.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $
+;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 




From ffjeld at common-lisp.net  Thu May 20 18:25:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 20 May 2004 14:25:12 -0400
Subject: [movitz-cvs] CVS update: movitz/bootblock.lisp 
Message-ID: <E1BQsEC-0005lg-00@common-lisp.net>

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

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

Date: Thu May 20 14:25:12 2004
Author: ffjeld

Index: movitz/bootblock.lisp
diff -u movitz/bootblock.lisp:1.8 movitz/bootblock.lisp:1.9
--- movitz/bootblock.lisp:1.8	Fri Apr 16 15:15:20 2004
+++ movitz/bootblock.lisp	Thu May 20 14:25:12 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.8 2004/04/16 19:15:20 ffjeld Exp $
+;;;; $Id: bootblock.lisp,v 1.9 2004/05/20 18:25:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -155,7 +155,6 @@
        (:movw :bx :es)
        (:xorw :bx :bx)
 
-       
        (:int #x13)			; Call BIOS routine
        (:jc 'read-error)
        (:movzxb :al :ecx)
@@ -285,7 +284,7 @@
        ;; Data
        welcome         (% format 8 "Loading Movitz ~D..~%
"
 			  ,(incf *bootblock-build*))
-       entering        (% format 8 ")~%
Enter..")
+       entering        (% format 8 "~%
Enter..")
        error           (% format 8 "Failed!)")
        track-start-msg (% format 8 "(")
        track-end-msg   (% format 8 ")")




From ffjeld at common-lisp.net  Fri May 21 09:38:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:38:52 -0400
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BR6UO-0006iq-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:38:52 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.28 movitz/image.lisp:1.29
--- movitz/image.lisp:1.28	Wed May 19 10:59:52 2004
+++ movitz/image.lisp	Fri May 21 05:38: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.28 2004/05/19 14:59:52 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.29 2004/05/21 09:38:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -569,9 +569,10 @@
 (defmethod image-intern-object ((image symbolic-image) object &optional (size (sizeof object)))
   (assert				; sanity check on "other" storage-types.
       (or (not (typep object 'movitz-heap-object-other))
-	  (and (= -6 (slot-offset (type-of object)
-				  (first (binary-record-slot-names (type-of object)))))
-	       (= -2 (slot-offset (type-of object) 'type))))
+	  (and (= (- (tag :other))
+		  (slot-offset (type-of object)
+			       (first (binary-record-slot-names (type-of object)))))
+	       (= +other-type-offset+ (slot-offset (type-of object) 'type))))
       ()
     "The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object))
   (etypecase object




From ffjeld at common-lisp.net  Fri May 21 09:39:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:39:30 -0400
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BR6V0-00016e-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:39:30 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.16 movitz/storage-types.lisp:1.17
--- movitz/storage-types.lisp:1.16	Wed Apr 21 12:22:56 2004
+++ movitz/storage-types.lisp	Fri May 21 05:39:30 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.16 2004/04/21 16:22:56 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.17 2004/05/21 09:39:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -84,7 +84,6 @@
 (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum))
 (defparameter +scan-skip-word+ #x00000003)
 
-
 (defun tag (type)
   (bt:enum-value 'other-type-byte type))
 
@@ -165,12 +164,14 @@
 ;;; Fixnums
 
 (eval-when (:compile-toplevel :execute :load-toplevel)
-(defconstant +movitz-fixnum-bits+ 30)
-(defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
-(defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
-(defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
-(defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
-(defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))))
+  (defconstant +movitz-fixnum-bits+ 30)
+  (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
+  (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
+  (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
+  (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
+  (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))
+
+  (defparameter +other-type-offset+ -6))
 
 (defun fixnum-integer (word)
   "For a Movitz word, that must be a fixnum, return the corresponding
@@ -325,24 +326,7 @@
 ;;; movitz-vectors
 
 (define-binary-class movitz-vector (movitz-heap-object-other)
-  ((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)
-   (num-elements
-    :binary-type lu16
-    :initarg :num-elements
-    :reader movitz-vector-num-elements)
-   (type
+  ((type
     :binary-type other-type-byte
     :reader movitz-vector-type
     :initform :vector)
@@ -360,43 +344,60 @@
     :binary-type lu16
     :initarg :fill-pointer
     :accessor movitz-vector-fill-pointer)
+   (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)
+   (num-elements
+    :binary-type lu16
+    :initarg :num-elements
+    :reader movitz-vector-num-elements)
    (data
     :binary-lisp-type :label)		; data follows physically here
    (symbolic-data
     :initarg :symbolic-data
     :accessor movitz-vector-symbolic-data))
-  (:slot-align type -2))
+  (:slot-align type #.+other-type-offset+))
 
 (defun vector-type-tag (element-type)
   (dpb (enum-value 'movitz-vector-element-type element-type)
        (byte 8 8)
        (enum-value 'other-type-byte :vector)))
 
-(define-binary-class movitz-new-vector (movitz-heap-object-other)
-  ((length
-    :binary-type u32
-    :initarg :length
-    :accessor movitz-simple-vector-length)
-   (type
-    :binary-type other-type-byte
-    :reader movitz-vector-type)
-   #+ignore
-   (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)
-   (data
-    :binary-lisp-type :label)
-   (symbolic-data
-    :initarg :symbolic-data
-    :accessor movitz-vector-symbolic-data))
-  (:slot-align type -2))
+;;;(define-binary-class movitz-new-vector (movitz-heap-object-other)
+;;;  ((length
+;;;    :binary-type u32
+;;;    :initarg :length
+;;;    :accessor movitz-simple-vector-length)
+;;;   (type
+;;;    :binary-type other-type-byte
+;;;    :reader movitz-vector-type)
+;;;   #+ignore
+;;;   (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)
+;;;   (data
+;;;    :binary-lisp-type :label)
+;;;   (symbolic-data
+;;;    :initarg :symbolic-data
+;;;    :accessor movitz-vector-symbolic-data))
+;;;  (:slot-align type #.+other-type-offset+))
 
 (defun movitz-type-word-size (type)
   (truncate (sizeof (intern (symbol-name type) :movitz)) 4))
@@ -745,14 +746,7 @@
 ;;; Compiled funobj
 
 (define-binary-class movitz-funobj (movitz-heap-object-other)
-  ((code-vector
-    :binary-type code-vector-word
-    :initform 'muerte::no-code-vector
-    :initarg :code-vector
-    :map-binary-write 'movitz-intern-code-vector
-    :map-binary-read-delayed 'movitz-word-code-vector
-    :accessor movitz-funobj-code-vector)
-   (type
+  ((type
     :binary-type other-type-byte
     :initform :funobj)
    (funobj-type
@@ -767,6 +761,13 @@
     ;; Bit    5: The code-vector's uses-stack-frame-p.
     :binary-type 'lu16
     :initform 0)
+   (code-vector
+    :binary-type code-vector-word
+    :initform 'muerte::no-code-vector
+    :initarg :code-vector
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :accessor movitz-funobj-code-vector)
    (code-vector%1op
     :binary-type code-pointer
     :initform 'muerte::trampoline-funcall%1op
@@ -858,7 +859,7 @@
     :initform :default
     :initarg :entry-protocol
     :reader funobj-entry-protocol))
-  (:slot-align type -2))
+  (:slot-align type #.+other-type-offset+))
 
 (defmethod write-binary-record ((obj movitz-funobj) stream)
   (declare (special *record-all-funobjs*))
@@ -908,12 +909,7 @@
 
 (define-binary-class movitz-funobj-standard-gf (movitz-funobj)
   ;; This class is binary congruent with movitz-funobj.
-  ((code-vector
-    :binary-type code-vector-word
-    :initform 'muerte::standard-gf-dispatcher
-    :map-binary-write 'movitz-intern-code-vector
-    :map-binary-read-delayed 'movitz-word-code-vector)
-   (type
+  ((type
     :binary-type other-type-byte)
    (funobj-type
     :binary-type movitz-funobj-type
@@ -922,6 +918,11 @@
     ;; Bits 0-4: The value of the start-stack-frame-setup label.
     :binary-type 'lu16
     :initform 0)
+   (code-vector
+    :binary-type code-vector-word
+    :initform 'muerte::standard-gf-dispatcher
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector)
    (code-vector%1op
     :initform 'muerte::standard-gf-dispatcher%1op
     :binary-type code-pointer
@@ -993,18 +994,11 @@
     :map-binary-read-delayed 'movitz-word)
    (plist
     :initform nil))
-  (:slot-align type -2))
+  (:slot-align type #.+other-type-offset+))
 
 (defmethod movitz-funobj-const-list ((funobj movitz-funobj-standard-gf))
   nil)
 
-#+ignore
-(defun make-movitz-funobj (lambda-list &key (name ""))
-  (check-type name (or symbol cons))
-  (make-instance 'movitz-funobj
-    :lambda-list lambda-list
-    :name name))
-
 (defun make-standard-gf (class slots &key lambda-list (name "unnamed")
 					  (function 'muerte::unbound)
 					  num-required-arguments
@@ -1020,51 +1014,27 @@
 
 ;;;
 
-#+ignore
-(define-binary-class movitz-bignum (movitz-heap-object-other)
-  ((low32
-    :binary-lisp-type u32
-    :map-binary-write 'movitz-intern
-    :map-binary-read-delayed 'movitz-word
-    :initarg :name)
-   (type
-    :binary-lisp-type other-type-byte
-    :initform :bignum)
+(define-binary-class movitz-struct (movitz-heap-object-other)
+  ((type
+    :binary-type other-type-byte
+    :initform :defstruct)
    (pad :binary-lisp-type 1)
    (length
     :binary-lisp-type lu16
     :initarg :length
-    :accessor movitz-bignum-length)
-   (slot0 :binary-lisp-type :label)	; the slot values follows here.
-   (slot-values
-    :initform '()
-    :initarg :slot-values
-    :accessor movitz-struct-slot-values))
-  (:slot-align type -2))
-
-;;;
-
-(define-binary-class movitz-struct (movitz-heap-object-other)
-  ((name
+    :accessor movitz-struct-length)
+   (name
     :binary-type word
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word
     :reader movitz-struct-name
     :initarg :name)
-   (type
-    :binary-type other-type-byte
-    :initform :defstruct)
-   (pad :binary-lisp-type 1)
-   (length
-    :binary-lisp-type lu16
-    :initarg :length
-    :accessor movitz-struct-length)
    (slot0 :binary-lisp-type :label)	; the slot values follows here.
    (slot-values
     :initform '()
     :initarg :slot-values
     :accessor movitz-struct-slot-values))
-  (:slot-align type -2))
+  (:slot-align type #.+other-type-offset+))
 
 (defmethod update-movitz-object ((movitz-struct movitz-struct) lisp-struct)
   (declare (ignore lisp-struct))
@@ -1271,15 +1241,15 @@
 ;;; std-instance
 
 (define-binary-class movitz-std-instance (movitz-heap-object-other)
-  ((dummy
+  ((type
+    :binary-type other-type-byte
+    :initform :std-instance)
+   (pad :binary-lisp-type 3)
+   (dummy
     :binary-type word
     :initform *movitz-nil*
     :map-binary-write 'movitz-intern
     :map-binary-read-delayed 'movitz-word)
-   (type
-    :binary-type other-type-byte
-    :initform :std-instance)
-   (pad :binary-lisp-type 3)
    (class
     :binary-type word
     :map-binary-write 'movitz-intern
@@ -1292,7 +1262,7 @@
     :map-binary-read-delayed 'movitz-word
     :initarg :slots
     :accessor movitz-std-instance-slots))
-  (:slot-align type -2))
+  (:slot-align type #.+other-type-offset+))
 
 ;; (defmethod movitz-object-offset ((obj movitz-std-instance)) (- #x1e))
 




From ffjeld at common-lisp.net  Fri May 21 09:39:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:39:43 -0400
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1BR6VD-0001kP-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:39:42 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.21 movitz/packages.lisp:1.22
--- movitz/packages.lisp:1.21	Wed Apr 21 12:00:25 2004
+++ movitz/packages.lisp	Fri May 21 05:39:40 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.21 2004/04/21 16:00:25 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.22 2004/05/21 09:39:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1284,6 +1284,7 @@
 	   #:dump-image
 
 	   #:other-type-byte
+	   #:+other-type-offset+
 	   #:parse-docstring-and-declarations
 	   #:global-constant-offset
 	   #:tag #:tag-name




From ffjeld at common-lisp.net  Fri May 21 09:40:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:40:11 -0400
Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt 
Message-ID: <E1BR6Vf-0004NJ-00@common-lisp.net>

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

Modified Files:
	bochsrc.txt 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:40:09 2004
Author: ffjeld

Index: movitz/bochsrc.txt
diff -u movitz/bochsrc.txt:1.1.1.1 movitz/bochsrc.txt:1.2
--- movitz/bochsrc.txt:1.1.1.1	Tue Jan 13 06:04:59 2004
+++ movitz/bochsrc.txt	Fri May 21 05:40:09 2004
@@ -36,5 +36,5 @@
 error: action=report
 # debug: action=report
 
-ips: 3000000
+ips: 2000000
 # com1: dev=/dev/ptypv




From ffjeld at common-lisp.net  Fri May 21 09:40:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:40:20 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1BR6Vo-0005GC-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:40:20 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.6 movitz/losp/muerte/scavenge.lisp:1.7
--- movitz/losp/muerte/scavenge.lisp:1.6	Tue Apr  6 20:34:52 2004
+++ movitz/losp/muerte/scavenge.lisp	Fri May 21 05:40:19 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.6 2004/04/07 00:34:52 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.7 2004/05/21 09:40:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -54,10 +54,11 @@
 	  (error "Illegal word ~Z at ~S." x scan))
 	 ((scavenge-typep x :funobj)
 	  ;; Process code-vector pointer specially..
-	  (let ((code-vector (%word-offset (memref scan 0 -1 :lisp) -2))
-		(num-jumpers (ldb (byte 14 0) (memref scan 0 6 :lisp))))
+	  (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)
-	    (map-heap-words function (+ scan 4) (+ scan 6)) ; scan funobj's lambda-list and name fields
+	    (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)
 	      (unless (eq code-vector new-code-vector)
@@ -65,21 +66,21 @@
 		(setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2))
 		;; Do more stuff here to update code-vectors and jumpers
 		))
-	    (incf scan (+ 6 num-jumpers)))) ; Don't scan the jumpers.
+	    (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers.
 	 ((scavenge-typep x :infant-object)
 	  (error "Scanning an infant object ~Z at ~S." x scan))
 	 ((or (scavenge-wide-typep x :vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
 	      (scavenge-wide-typep x :vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :character)))
-	  (let ((len (memref scan -2 0 :unsigned-byte16)))
-	    (incf scan (* 2 (truncate (+ 7 len) 8)))))
+	  (let ((len (memref scan 2 0 :unsigned-byte16)))
+	    (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
-	  (let ((len (memref scan -2 0 :unsigned-byte16)))
-	    (incf scan (* 2 (truncate (+ 3 len) 4)))))
+	  (let ((len (memref scan 2 0 :unsigned-byte16)))
+	    (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
-	  (let ((len (memref scan -2 0 :unsigned-byte16)))
-	    (incf scan (* 2 (truncate (+ 1 len) 2)))))
+	  (let ((len (memref scan 2 0 :unsigned-byte16)))
+	    (incf scan (1+ (* 2 (truncate (+ 1 len) 2))))))
 	 ((eq x (fixnum-word 3))
 	  (incf scan)
 	  (incf scan (memref scan 0 0 :lisp)))




From ffjeld at common-lisp.net  Fri May 21 09:40:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:40:48 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1BR6WG-0005d6-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:40:48 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.18 movitz/losp/muerte/basic-macros.lisp:1.19
--- movitz/losp/muerte/basic-macros.lisp:1.18	Thu May 20 13:43:46 2004
+++ movitz/losp/muerte/basic-macros.lisp	Fri May 21 05:40:48 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.18 2004/05/20 17:43:46 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.19 2004/05/21 09:40:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -522,9 +522,10 @@
      (: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 -2))))
+	 `((: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 -2))))))
+	 `((: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))
@@ -693,7 +694,7 @@
        (:cmpb 7 :cl)
        (:jne '(:sub-program (not-funobj)
 	       (:int 69)))
-       (:cmpb ,(movitz::tag :funobj) (:edx -2))
+       (:cmpb ,(movitz:tag :funobj) (:edx ,movitz:+other-type-offset+))
        (:jne 'not-funobj)
        (:movl :edx :esi)
       funobj-ok
@@ -743,7 +744,7 @@
 	    (:testb 7 :cl)
 	    (:jne '(:sub-program (not-funobj)
 		    (:int 69)))
-	    (:cmpb ,(movitz::tag :funobj) (:edx -2))
+	    (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+))
 	    (:jne 'not-funobj)
 	    (:movl :edx :esi)
 	   funobj-ok
@@ -765,7 +766,7 @@
 	   (:cmpb 7 :cl)
 	   (:jnz '(:sub-program (not-funobj)
 		   (:int 69)))
-	   (:cmpb ,(movitz::tag :funobj) (:edx -2))
+	   (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+))
 	   (:jne 'not-funobj)
 	   (:movl :edx :esi)
 	  funobj-ok
@@ -787,7 +788,7 @@
 	   (:cmpb 7 :cl)
 	   (:jnz '(:sub-program (not-funobj)
 		   (:int 69)))
-	   (:cmpb ,(movitz::tag :funobj) (:edx -2))
+	   (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+))
 	   (:jne 'not-funobj)
 	   (:movl :edx :esi)
 	  funobj-ok




From ffjeld at common-lisp.net  Fri May 21 09:41:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:41:12 -0400
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BR6We-0006HA-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:41:12 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.16 movitz/losp/muerte/primitive-functions.lisp:1.17
--- movitz/losp/muerte/primitive-functions.lisp:1.16	Wed Apr 21 11:08:36 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Fri May 21 05:41:11 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.16 2004/04/21 15:08:36 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.17 2004/05/21 09:41:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -576,7 +576,7 @@
 (define-primitive-function fast-class-of-other ()
   "Return the class of an other object."
   (with-inline-assembly (:returns :multiple-values)
-    (:movl (:eax -2) :ecx)
+    (:movl (:eax #.movitz:+other-type-offset+) :ecx)
     (:cmpb #.(movitz::tag :std-instance) :cl)
     (:jne 'not-std-instance)
     (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax)




From ffjeld at common-lisp.net  Fri May 21 09:41:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:41:39 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1BR6X5-0006oE-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:41:39 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.7 movitz/losp/muerte/defstruct.lisp:1.8
--- movitz/losp/muerte/defstruct.lisp:1.7	Mon Apr 19 18:38:16 2004
+++ movitz/losp/muerte/defstruct.lisp	Fri May 21 05:41:39 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.7 2004/04/19 22:38:16 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.8 2004/05/21 09:41:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,52 +44,54 @@
     (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
     (:testb 7 :cl)
     (:jnz 'fail)
-    (:cmpb #.(movitz:tag :defstruct) (-2 :eax))
+    (: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)))
     fail))
 
 (defun structure-ref (object slot-number)
-  (macrolet ((do-it ()
-	       `(with-inline-assembly (:returns :eax)
-		  ;; type test
-		  (:compile-form (:result-mode :eax) object)
-		  (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		  (:testb 7 :cl)
-		  (:jne '(:sub-program (type-error) (:int 66)))
-		  (:cmpb ,(movitz:tag :defstruct) (-2 :eax))
-		  (:jne '(:sub-program (type-error) (:int 66)))
-		  ;; 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))
-				 :eax))
-		      `((:compile-form  (:result-mode :untagged-fixnum-ecx) slot-number)
-			(:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
-			       :eax))))))
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    ;; type test
+	    (:compile-form (:result-mode :eax) object)
+	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jne '(:sub-program (type-error) (:int 66)))
+	    (:cmpb ,(movitz:tag :defstruct) (:eax ,movitz:+other-type-offset+))
+	    (:jne '(:sub-program (type-error) (:int 66)))
+	    ;; 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))
+			   :eax))
+		`((:compile-form  (:result-mode :untagged-fixnum-ecx) slot-number)
+		  (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
+			 :eax))))))
     (do-it)))
 
 (defun (setf structure-ref) (value object slot-number)
-  (macrolet ((do-it ()
-	       (assert (= 4 movitz::+movitz-fixnum-factor+))
-	       `(with-inline-assembly (:returns :eax)
-		  ;; type test
-		  (:compile-two-forms (:eax :ebx) object slot-number)
-		  (:leal (:eax ,(- (movitz:tag :other))) :ecx)
-		  (:testb 7 :cl)
-		  (:jne '(:sub-program (type-error) (:int 66)))
-		  (:cmpb ,(movitz:tag :defstruct) (-2 :eax))
-		  (: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)
-		  (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
-		  (:jnz '(:sub-program (not-fixnum) (:int 107)))
-		  (: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))))))
+  (macrolet
+      ((do-it ()
+	 (assert (= 4 movitz::+movitz-fixnum-factor+))
+	 `(with-inline-assembly (:returns :eax)
+	    ;; type test
+	    (:compile-two-forms (:eax :ebx) object slot-number)
+	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (: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)
+	    (:testb ,movitz::+movitz-fixnum-zmask+ :bl)
+	    (:jnz '(:sub-program (not-fixnum) (:int 107)))
+	    (: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))))))
     (do-it)))
 
 (defun struct-accessor-prototype (object)
@@ -100,7 +102,7 @@
     (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx)
     (:testb 7 :cl)
     (:jne '(:sub-program (type-error) (:int 66)))
-    (:cmpb #.(movitz:tag :defstruct) (-2 :eax))
+    (: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)))
@@ -119,7 +121,7 @@
     (:leal (:ebx #.(cl:- (movitz:tag :other))) :ecx)
     (:testb 7 :cl)
     (:jnz '(:sub-program (type-error) (:int 66)))
-    (:cmpb #.(movitz:tag :defstruct) (-2 :ebx))
+    (: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)))




From ffjeld at common-lisp.net  Fri May 21 09:41:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 21 May 2004 05:41:59 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BR6XP-0006qj-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
The layout of heap objects has been changed such that the type-code is
now the "first" byte in the object.

Date: Fri May 21 05:41:58 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.19 movitz/losp/muerte/arrays.lisp:1.20
--- movitz/losp/muerte/arrays.lisp:1.19	Thu May 20 13:41:46 2004
+++ movitz/losp/muerte/arrays.lisp	Fri May 21 05:41:58 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.19 2004/05/20 17:41:46 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.20 2004/05/21 09:41:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -186,69 +186,72 @@
 (defun aref (vector &rest subscripts)
   (numargs-case
    (2 (vector index)
-      (with-inline-assembly (:returns :eax)
-	(:compile-form (:result-mode :eax) vector)
-	(:compile-form (:result-mode :ebx) index)
-	(:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
-	(:testb #.movitz::+movitz-fixnum-zmask+ :bl)
-	(:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum
-	(:andl #.(cl:ash #x000ffff movitz::+movitz-fixnum-shift+) :ebx)
-
-	(:testb 7 :cl)
-	(:jnz '(:sub-program ()
-		(:compile-form (:result-mode :ignore)
-		 (error "Not a vector: ~S" vector))))
+      (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 -2) :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 (length vector)))))
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
+		(:movzxw (:eax ,movitz:+other-type-offset+) :ecx)
 
-	(: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)
+		(: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 (length vector)))))
+
+		(: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-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
-	(:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx)
-	(:jg '(:sub-program (:overflowing-u32)
-	       (:int 107)))
-	(:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax)
-	(:jmp 'done)
-
-       not-u32
-	(:compile-form (:result-mode :ignore)
-		       (error "Not a vector: ~S" vector))
+	       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
+		(:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx)
+		(:jg '(:sub-program (:overflowing-u32)
+		       (:int 107)))
+		(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+		(:jmp 'done)
+
+	       not-u32
+		(:compile-form (:result-mode :ignore)
+			       (error "Not a vector: ~S" vector))
 
-       done))
+	       done)))
+	(do-it)))
    (t (vector &rest subscripts)
       (declare (ignore vector subscripts))
       (error "Multi-dimensional arrays not implemented."))))
@@ -256,82 +259,85 @@
 (defun (setf aref) (value vector &rest subscripts)
   (numargs-case
    (3 (value vector index)
-      (with-inline-assembly (:returns :ebx)
-	(:compile-form (:result-mode :ebx) value)
-	(:compile-form (:result-mode :eax) vector)
-
-	(:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
-	(:testb 7 :cl)
-	(:jnz '(:sub-program ()
-		(:compile-form (:result-mode :ignore)
-		 (error "Not a vector: ~S" vector))))
-	(:movzxw (:eax -2) :edx)
+      (macrolet
+	  ((do-it ()
+	     `(with-inline-assembly (:returns :ebx)
+		(:compile-form (:result-mode :ebx) value)
+		(:compile-form (:result-mode :eax) vector)
+
+		(:leal (:eax #.(cl:- (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 #.(cl: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)
+		(:compile-form (:result-mode :ecx) index)
+		(:testb #.movitz::+movitz-fixnum-zmask+ :cl)
+		(:jnz '(:sub-program () (:int 107))) ; index not fixnum
+		(:andl #.(cl: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) (cl:- -1 (cl:* #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-character
+		(:cmpl #.(movitz:vector-type-tag :u8) :edx)
+		(:jnz 'not-u8)
+		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #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 #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #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)
-	(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
-	(:jnz '(:sub-program (not-u32-value)
-		(:compile-form (:result-mode :ignore)
-		 (error "Value not (unsigned-byte 32): ~S" value))))
-	(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-       	(:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-	(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
-	(:jmp 'done)
-
-       not-u32
-	(:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
-       done))
+	       not-u8
+		(:cmpl #.(movitz:vector-type-tag :u16) :edx)
+		(:jnz 'not-u16)
+		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #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)
+		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
+		(:jnz '(:sub-program (not-u32-value)
+			(:compile-form (:result-mode :ignore)
+			 (error "Value not (unsigned-byte 32): ~S" value))))
+		(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+		(:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+		(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :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))
       (error "Multi-dimensional arrays not implemented."))))




From ffjeld at common-lisp.net  Mon May 24 14:58:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:01 -0400
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BSGtt-0005Jo-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:01 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.59 movitz/compiler.lisp:1.60
--- movitz/compiler.lisp:1.59	Fri Apr 23 10:58:52 2004
+++ movitz/compiler.lisp	Mon May 24 10:58:00 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.59 2004/04/23 14:58:52 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.60 2004/05/24 14:58:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -4786,12 +4786,9 @@
 					 :provider provider))
 	  (:untagged-fixnum-ecx
 	   (case (result-mode-type desired-result)
-	     ((:eax :ebx :ecx :edx)
-	      (values (append code `((:cmpl ,+movitz-most-positive-fixnum+ :ecx)
-				     (:ja '(:sub-program ()
-					    (:int 4)))
-				     (:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset))
-					    ,desired-result)))
+	     ((:eax :single-value)
+	      (values (append code
+			      `((:call (:edi ,(global-constant-offset 'normalize-u32-ecx)))))
 		      desired-result))
 	     (t (make-result-and-returns-glue desired-result :eax
 					      (make-result-and-returns-glue :eax :untagged-fixnum-ecx code




From ffjeld at common-lisp.net  Mon May 24 14:58:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:07 -0400
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <E1BSGtz-0005Vd-00@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:07 2004
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.4 movitz/stream-image.lisp:1.5
--- movitz/stream-image.lisp:1.4	Wed Mar 31 11:34:47 2004
+++ movitz/stream-image.lisp	Mon May 24 10:58:07 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.4 2004/03/31 16:34:47 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.5 2004/05/24 14:58:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -80,7 +80,8 @@
 		  (:other
 		   (setf (image-stream-position image)
 		     (+ 4 (extract-pointer word)))
-		   (let ((type-tag (read-binary 'other-type-byte (image-stream image))))
+		   (let* ((type-code (read-binary 'u8 (image-stream image)))
+			  (type-tag (enum-symbolic-value 'other-type-byte type-code)))
 		     (setf (image-stream-position image)
 		       (extract-pointer word))
 		     (case type-tag
@@ -92,7 +93,8 @@
 			   (read-binary 'movitz-struct (image-stream image)))
 		       (:std-instance
 			(read-binary 'movitz-std-instance (image-stream image)))
-		       (t (warn "unknown other object: #x~X: ~S" word type-tag)
+		       (t (warn "unknown other object: #x~X: ~S code #x~X."
+				word type-tag type-code)
 			  (make-instance 'movitz-fixnum :value (truncate word 4))))))
 		  (t (make-instance 'movitz-fixnum :value 0)))))
     (when (typep object 'movitz-heap-object)




From ffjeld at common-lisp.net  Mon May 24 14:58:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:12 -0400
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BSGu4-0005Z1-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:12 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.29 movitz/image.lisp:1.30
--- movitz/image.lisp:1.29	Fri May 21 05:38:52 2004
+++ movitz/image.lisp	Mon May 24 10:58:12 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.29 2004/05/21 09:38:52 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.30 2004/05/24 14:58:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -226,6 +226,11 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
+   (normalize-u32-ecx
+    :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
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
@@ -543,6 +548,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:vector muerte.cl:string muerte.cl:array
     muerte.cl:class muerte.cl:standard-class
     muerte.cl:standard-generic-function
@@ -553,9 +559,10 @@
     muerte:illegal-object))
 
 (defun class-object-offset (name)
-  (+ (bt:slot-offset 'movitz-vector 'data)
-     (* 4 (1+ (or (position name (image-classes-map *image*))
-		  (error "No class named ~S in class-map." name))))))
+  (let ((name (translate-program name :cl :muerte.cl)))
+    (+ (bt:slot-offset 'movitz-vector 'data)
+       (* 4 (1+ (or (position name (image-classes-map *image*))
+		    (error "No class named ~S in class-map." name)))))))
 
 (defun unbound-value ()
   (declare (special *image*))
@@ -1361,7 +1368,7 @@
 	 (null *movitz-nil*)
 	 ((member t) (movitz-read 'muerte.cl:t))
 	 (symbol (intern-movitz-symbol expr))
-	 (integer (make-movitz-fixnum 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*))




From ffjeld at common-lisp.net  Mon May 24 14:58:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:17 -0400
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <E1BSGu9-0005cu-00@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:17 2004
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.5 movitz/movitz-mode.el:1.6
--- movitz/movitz-mode.el:1.5	Wed May 19 10:57:46 2004
+++ movitz/movitz-mode.el	Mon May 24 10:58:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 18:12:17 2001
 ;;;;                
-;;;; $Id: movitz-mode.el,v 1.5 2004/05/19 14:57:46 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.6 2004/05/24 14:58:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -301,6 +301,7 @@
   (put 'vector-double-dispatch tag '(like case))
   (put 'sequence-dispatch tag '(like case))
   (put 'sequence-double-dispatch tag '(like case))
+  (put 'number-double-dispatch tag '(like case))
   (put 'simple-stream-dispatch tag '(like case))
   (put 'with-inline-assembly tag '(like prog))
   (put 'with-inline-assembly-case tag '(like prog))




From ffjeld at common-lisp.net  Mon May 24 14:58:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:22 -0400
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1BSGuE-0005j1-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:22 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.17 movitz/storage-types.lisp:1.18
--- movitz/storage-types.lisp:1.17	Fri May 21 05:39:30 2004
+++ movitz/storage-types.lisp	Mon May 24 10:58: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.17 2004/05/21 09:39:30 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.18 2004/05/24 14:58:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -74,6 +74,7 @@
   :run-time-context #x50
   :illegal #x13
   :infant-object #x23
+  :bignum #x4a
 
   ;; :simple-vector #x20
   ;; :character-vector 
@@ -84,8 +85,9 @@
 (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum))
 (defparameter +scan-skip-word+ #x00000003)
 
-(defun tag (type)
-  (bt:enum-value 'other-type-byte type))
+(defun tag (type &optional (wide-tag 0))
+  (logior (bt:enum-value 'other-type-byte type)
+	  (ash wide-tag 8)))
 
 (defun tag-name (number)
   (bt:enum-symbolic-value 'other-type-byte number))
@@ -1289,3 +1291,42 @@
 	       :stream stream))))
   object)
 
+;;;;
+
+(define-binary-class movitz-bignum (movitz-heap-object-other)
+  ((type
+    :binary-type other-type-byte
+    :initform :bignum)
+   (sign
+    :binary-type u8
+    :initarg :sign
+    :accessor movitz-bignum-sign)
+   (length
+    :binary-type lu16
+    :initarg :length
+    :accessor movitz-bignum-length)
+   (bigit0 :binary-type :label)
+   (value
+    :initarg :value
+    :accessor movitz-bignum-value))
+  (:slot-align type #.+other-type-offset+))
+
+(defmethod write-binary-record ((obj movitz-bignum) stream)
+  (let* ((num (movitz-bignum-value obj))
+	 (length (ceiling (integer-length (abs num)) 32)))
+    (check-type length (unsigned-byte 16))
+    (setf (movitz-bignum-length obj) length
+	  (movitz-bignum-sign obj) (if (minusp num) #xff #x00))
+    (+ (call-next-method)		; header
+       (loop for b from 0 below length
+	   summing (write-binary 'lu32 stream (ldb (byte 32 (* b 32)) (abs num)))))))
+
+(defun make-movitz-integer (value)
+  (if (<= +movitz-most-negative-fixnum+ value +movitz-most-positive-fixnum+)
+      (make-movitz-fixnum value)
+    (make-instance 'movitz-bignum
+      :value value)))
+
+(defmethod sizeof ((obj movitz-bignum))
+  (+ (sizeof 'movitz-bignum)
+     (* 4 (ceiling (integer-length (abs (movitz-bignum-value obj))) 32))))




From ffjeld at common-lisp.net  Mon May 24 14:58:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:27 -0400
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1BSGuJ-00060J-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:27 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.22 movitz/packages.lisp:1.23
--- movitz/packages.lisp:1.22	Fri May 21 05:39:40 2004
+++ movitz/packages.lisp	Mon May 24 10:58:27 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.22 2004/05/21 09:39:40 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.23 2004/05/24 14:58:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1283,6 +1283,7 @@
   (:export #:create-image
 	   #:dump-image
 
+	   #:class-object-offset
 	   #:other-type-byte
 	   #:+other-type-offset+
 	   #:parse-docstring-and-declarations




From ffjeld at common-lisp.net  Mon May 24 14:58:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:35 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BSGuR-00065j-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:35 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.10 movitz/losp/los0-gc.lisp:1.11
--- movitz/losp/los0-gc.lisp:1.10	Fri Apr 16 10:44:42 2004
+++ movitz/losp/los0-gc.lisp	Mon May 24 10:58:34 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.10 2004/04/16 14:44:42 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.11 2004/05/24 14:58:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,6 +72,33 @@
     (:movl :ecx (:edx 2))
     (:ret)))
 
+(define-primitive-function los0-normalize-u32-ecx ()
+  "Make u32 in ECX into a fixnum or bignum."
+  (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
+	   retry-cons
+	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+	    (:movl (:edx 2) :eax)
+	    (:cmpl #x3fff4 :eax)
+	    (:jge '(:sub-program ()
+		    (:int 113)		; This interrupt can be retried.
+		    (:jmp 'retry-cons)))
+	    (:movl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+		   (:edx :eax 2))
+	    (:movl :ecx (:edx :eax 6))
+	    (:addl 8 :eax)
+	    (:movl :eax (:edx 2))
+	    (:leal (:edx :eax) :eax)
+	    (:ret)
+	    (:int 107))))
+    (do-it)))
+
 (defun los0-malloc-clumps (clumps)
   (check-type clumps (integer 0 4000))
   (with-inline-assembly (:returns :eax)
@@ -129,6 +156,10 @@
   (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-normalize-u32-ecx)))
+    (check-type conser vector)
+    (setf (%run-time-context-slot 'muerte::normalize-u32-ecx)
       conser))
   (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
     (setf (symbol-function 'muerte:malloc-clumps)




From ffjeld at common-lisp.net  Mon May 24 14:58:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:40 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1BSGuW-00068r-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:39 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.13 movitz/losp/los0.lisp:1.14
--- movitz/losp/los0.lisp:1.13	Fri Apr 23 11:04:07 2004
+++ movitz/losp/los0.lisp	Mon May 24 10:58:39 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.13 2004/04/23 15:04:07 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.14 2004/05/24 14:58:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -262,6 +262,24 @@
    exit
     (warn "exited: ~S" c)))
 
+
+(defun test-bignum ()
+  123456789123456)
+
+(defun ff32 ()
+  #xffffffff)
+
+(defun one32 ()
+  #x100000000)
+
+(defun test-nbignum ()
+  -123456789123456)
+
+(defun gt5 (x)
+  (<= x 5))
+
+(defun xplus (x)
+  (typep x '(integer 0 *)))
 
 (defstruct xxx
   x y (z 'init-z))




From ffjeld at common-lisp.net  Mon May 24 14:58:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:44 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1BSGua-0006BX-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:44 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.8 movitz/losp/muerte/print.lisp:1.9
--- movitz/losp/muerte/print.lisp:1.8	Wed Apr 21 11:07:48 2004
+++ movitz/losp/muerte/print.lisp	Mon May 24 10:58: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.8 2004/04/21 15:07:48 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.9 2004/05/24 14:58:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -83,7 +83,8 @@
       (write-digit (rem x base) stream))))
 
 (defun write-lowlevel-integer (x stream base comma-char comma-interval mincol padchar sign-char pos)
-  (let ((bigit (truncate x base)))
+  (multiple-value-bind (bigit rem)
+      (truncate x base)
     (cond
      ((zerop bigit)
       (when mincol
@@ -94,8 +95,8 @@
       (when sign-char
 	(write-char sign-char stream)))
      (t (write-lowlevel-integer bigit stream base comma-char comma-interval
-				mincol padchar sign-char (1+ pos)))))
-  (write-digit (rem x base) stream)
+				mincol padchar sign-char (1+ pos))))
+    (write-digit rem stream))
   (when (and comma-interval (plusp pos) (zerop (rem pos comma-interval)))
     (write-char comma-char stream))
   nil)
@@ -239,7 +240,8 @@
 			(if (and (plusp (length name))
 				 (every (lambda (c)
 					  (or (upper-case-p c)
-					      (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=))
+					      (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\&
+							  #\/ #\< #\> #\=))
 					      (digit-char-p c)))
 					name)
 				 (not (every (lambda (c)




From ffjeld at common-lisp.net  Mon May 24 14:58:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:51 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BSGuh-0006Eq-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:51 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.10 movitz/losp/muerte/integers.lisp:1.11
--- movitz/losp/muerte/integers.lisp:1.10	Wed May 19 11:42:08 2004
+++ movitz/losp/muerte/integers.lisp	Mon May 24 10:58: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.10 2004/05/19 15:42:08 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.11 2004/05/24 14:58:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,6 +22,12 @@
 (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+) *))
+
 (defun fixnump (x)
   (typep x 'fixnum))
 
@@ -242,10 +248,26 @@
   "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)))
-    (:cmpl :ebx :eax)
+    (: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)))
 
 ;;;
@@ -256,8 +278,8 @@
 	 (movitz:movitz-constantp max env))
     (let ((min (movitz:movitz-eval min env))
 	  (max (movitz:movitz-eval max env)))
-      (check-type min integer)
-      (check-type max integer)
+      (check-type min fixnum)
+      (check-type max fixnum)
       ;; (warn "~D -- ~D" min max)
       (cond
        ((movitz:movitz-constantp x env)
@@ -296,7 +318,7 @@
    #+ignore				; this is buggy.
    ((movitz:movitz-constantp min env)
     (let ((min (movitz:movitz-eval min env)))
-      (check-type min integer)
+      (check-type min fixnum)
       (cond
        ((minusp min)
 	`(let ((x ,x))
@@ -372,7 +394,7 @@
 	   (declare (dynamic-extent more-numbers))
 	   (cond
 	    ((null more-numbers)
-	     (check-type number integer)
+	     (check-type number fixnum)
 	     t)
 	    ((not (cdr more-numbers))
 	     (,2op-name number (first more-numbers)))
@@ -514,7 +536,7 @@
      (if (< number1 number2)
 	 number2 number1))
   (let ((label (gensym)))
-    `(with-inline-assembly (:returns :eax :type integer)
+    `(with-inline-assembly (:returns :eax :type fixnum)
        (:compile-two-forms (:eax :ebx) ,number1 ,number2)
        (:movl :ebx :ecx)
        (:orl :eax :ecx)
@@ -650,7 +672,7 @@
     `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1))
    ((movitz:movitz-constantp factor1 env)
     (let ((f1 (movitz:movitz-eval factor1 env)))
-      (check-type f1 integer)
+      (check-type f1 fixnum)
       (case f1
 	(0 `(progn ,factor2 0))
 	(1 factor2)
@@ -708,9 +730,9 @@
   `(do-result-mode-case ()
      (:plural
       (no-macro-call , at form))
-     (t (truncate%2ops%1ret ,number ,divisor))))
+     (t (truncate%1ret ,number ,divisor))))
 
-(defun truncate%2ops%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)
@@ -723,7 +745,7 @@
     (:shll #.movitz::+movitz-fixnum-shift+ :eax)
     (:clc)))
 
-(define-compiler-macro truncate%2ops%1ret (&whole form &environment env number divisor)
+(define-compiler-macro truncate%1ret (&whole form &environment env number divisor)
   (cond
    ((movitz:movitz-constantp divisor env)
     (let ((d (movitz:movitz-eval divisor env)))
@@ -731,7 +753,7 @@
       (case d
 	(0 (error "Truncate by zero."))
 	(1 number)
-	(t `(with-inline-assembly (:returns :eax :type integer)
+	(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)
@@ -741,26 +763,116 @@
 	      (:shll #.movitz::+movitz-fixnum-shift+ :eax))))))
    (t form)))
 
+(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 truncate (number &optional (divisor 1))
   (numargs-case
    (1 (number)
       (values number 0))
    (t (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)
-	(:movl :edx :ebx)
-	(:xorl :ecx :ecx)
-	(:movb 2 :cl)			; return values: qutient, remainder.
-	(:stc)))))
-
+      (number-double-dispatch (number divisor)
+	((fixnum fixnum)
+	 (with-inline-assembly (:returns :multiple-values)
+	   (:compile-form (:result-mode :eax) number)
+	   (:compile-form (:result-mode :ebx) divisor)
+	   (:std)
+	   (:cdq :eax :edx)
+	   (:idivl :ebx :eax :edx)
+	   (:shll #.movitz::+movitz-fixnum-shift+ :eax)
+	   (:cld)
+	   (:movl :edx :ebx)
+	   (:xorl :ecx :ecx)
+	   (:movb 2 :cl)		; return values: qutient, remainder.
+	   (:stc)))
+	((positive-bignum positive-fixnum)
+	 (let (r n)
+	   (with-inline-assembly (:returns :multiple-values)
+	     (:compile-form (:result-mode :ebx) number)
+	     (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx)
+	     (:cmpl 1 :ecx)
+	     (: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)
+	     (:xorl :edx :edx)
+	     (:divl :ecx :eax :edx)
+	     (:movl :eax :ecx)
+	     (:shll #.movitz:+movitz-fixnum-shift+ :edx)
+	     (:movl :edi :eax)
+	     (:cld)
+	     (:pushl :edx)
+	     (:call-global-constant normalize-u32-ecx)
+	     (:popl :ebx)
+	     (:jmp 'done)
+	    not-size1
+	     (:cmpl 2 :ecx)
+	     (:jne 'not-size2)
+	     (:compile-form (:result-mode :ecx) divisor)
+	     (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
+	     (:std)
+	     (:movl (:ebx #.(cl:+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+		    :edx)
+	     (:cmpl :ecx :edx)
+	     (:jae 'not-size2)
+	     (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax)
+	     (:divl :ecx :eax :edx)
+	     (:movl :eax :ecx)
+	     (:shll #.movitz:+movitz-fixnum-shift+ :edx)
+	     (:movl :edi :eax)
+	     (:cld)
+	     (:pushl :edx)
+	     (:call-global-constant normalize-u32-ecx)
+	     (:popl :ebx)
+	     (:jmp 'done)
+	    not-size2
+	     (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
+			       -4 (:ecx 4)))
+	     (:jc 'shrink-not-size2)
+	    not-shrink
+	     (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax)
+	     (:compile-form (:result-mode :eax)
+			    (malloc-words (with-inline-assembly (:returns :eax))))
+	     (:store-lexical (:lexical-binding r) :eax :type t)
+	     (:compile-form (:result-mode :ebx) number)
+	     (: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)
+
+	    divide-loop
+	     (:load-lexical (:lexical-binding number) :ebx)
+	     (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)
+			  -4 (:ecx 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 4)))
+	     (:subl 1 :ecx)
+	     (:jnz 'divide-loop)
+	     (:movl :ebx :eax)
+	     (:leal ((:edx #.movitz:+movitz-fixnum-factor+)) :ebx)
+	     (:movl :edi :edx)
+	     (:movl (:ebp -4) :esi)
+	     (:cld)
+	     (:jmp 'done)
+	    shrink-not-size2
+	     (:int 107)
+	    done
+	     (:movl 2 :ecx)
+	     (:stc))))
+	))))
 
 (defun round (number &optional (divisor 1))
   "Mathematical rounding."
@@ -1147,4 +1259,4 @@
 	  (values q 0))
 	 (t (values (1- q) (+ r divisor))))))
    (t (n &optional (divisor 1))
-      (floor n divisor))))
\ No newline at end of file
+      (floor n divisor))))




From ffjeld at common-lisp.net  Mon May 24 14:58:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:58:56 -0400
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BSGum-0006W9-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:58:56 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.17 movitz/losp/muerte/primitive-functions.lisp:1.18
--- movitz/losp/muerte/primitive-functions.lisp:1.17	Fri May 21 05:41:11 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Mon May 24 10:58:56 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.17 2004/05/21 09:41:11 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.18 2004/05/24 14:58:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -441,8 +441,8 @@
 
 (defun malloc-initialize (buffer-start buffer-size)
   "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units."
-  (check-type buffer-start integer)
-  (check-type buffer-size integer)
+  (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)
@@ -504,6 +504,17 @@
     return-ok
     (:ret)))
 
+
+(define-primitive-function normalize-u32-ecx ()
+  "Make u32 in ECX into a fixnum or bignum."
+  (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!
+
 ;;;;
 
 (define-primitive-function fast-class-of-even-fixnum ()
@@ -566,32 +577,42 @@
     (:globally (:movl (:edi (:edi-offset classes)) :ebx))
     (:cmpl :edi :eax)
     (:je 'null)
-    (:movl (:ebx #.(movitz::class-object-offset 'illegal-object)) :eax)
+    (:movl (:ebx #.(movitz:class-object-offset 'illegal-object)) :eax)
     (:jmp 'not-null)
    null
-    (:movl (:ebx #.(movitz::class-object-offset 'null)) :eax)
+    (:movl (:ebx #.(movitz:class-object-offset 'null)) :eax)
    not-null
     (:ret)))
 
 (define-primitive-function fast-class-of-other ()
   "Return the class of an other object."
-  (with-inline-assembly (:returns :multiple-values)
-    (:movl (:eax #.movitz:+other-type-offset+) :ecx)
-    (:cmpb #.(movitz::tag :std-instance) :cl)
-    (:jne 'not-std-instance)
-    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax)
-    (:ret)
-   not-std-instance
-    (:cmpw #.(cl:+ (movitz::tag :funobj)
-		   (cl:ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8))
-	   :cx)
-    (:jne 'not-std-gf-instance)
-    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-funobj-standard-gf 'movitz::standard-gf-class))
-	   :eax)
-    (:ret)
-   not-std-gf-instance
-    (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi))
-    (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op)))))
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+	    (:cmpb ,(movitz:tag :std-instance) :cl)
+	    (:jne 'not-std-instance)
+	    (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax)
+	    (:ret)
+	   not-std-instance
+	    (:cmpw ,(+ (movitz:tag :funobj)
+		       (ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8))
+		   :cx)
+	    (:jne 'not-std-gf-instance)
+	    (:movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf
+					  'movitz::standard-gf-class))
+		   :eax)
+	    (:ret)
+	   not-std-gf-instance
+	    (:globally (:movl (:edi (:edi-offset classes)) :ebx))
+	    (:cmpb ,(movitz:tag :bignum) :cl)
+	    (:jne 'not-bignum)
+	    (:movl (:ebx ,(movitz:class-object-offset 'integer)) :eax)
+	    (:ret)
+	   not-bignum
+	    (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi))
+	    (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))))
+    (do-it)))
 
 (defun complicated-class-of (object)
   (typecase object




From ffjeld at common-lisp.net  Mon May 24 14:59:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:59:02 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1BSGus-0008M6-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:59:02 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.11 movitz/losp/muerte/typep.lisp:1.12
--- movitz/losp/muerte/typep.lisp:1.11	Mon Apr 19 15:51:01 2004
+++ movitz/losp/muerte/typep.lisp	Mon May 24 10:59: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.11 2004/04/19 19:51:01 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.12 2004/05/24 14:59:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -170,10 +170,22 @@
 		((t) 't)
 		((nil) 'nil)
 		(null `(not ,object))
-		((fixnum integer number)
+		((fixnum)
 		 `(with-inline-assembly (:returns :boolean-zf=1)
 		    (:compile-form (:result-mode :eax) ,object)
 		    (:testb ,movitz::+movitz-fixnum-zmask+ :al)))
+		((integer number rational)
+		 `(with-inline-assembly-case ()
+		    (do-case (t :boolean-zf=1 :labels (done))
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:testb ,movitz:+movitz-fixnum-zmask+ :al)
+		      (:jz 'done)
+		      (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+		      (:testb 7 :cl)
+		      (:jnz 'done)
+		      (:cmpb ,(movitz:tag :bignum)
+			     (:eax ,movitz:+other-type-offset+))
+		     done)))
 		(symbol
 		 `(with-inline-assembly (:returns :boolean-zf=1)
 		    (:compile-form (:result-mode :eax) ,object)
@@ -246,17 +258,59 @@
 		    ((integer)
 		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
 			 (cdr type)
-		       (let* ((min movitz:+movitz-most-negative-fixnum+)
-			      (max movitz:+movitz-most-positive-fixnum+)
-			      (lower-limit (if (eq lower-limit '*) min lower-limit))
-			      (upper-limit (if (eq upper-limit '*) max upper-limit)))
-			 (assert (<= lower-limit upper-limit) ()
-			   "The lower limit of an integer type must be smaller than the upper limit.")
+		       (let* ((lower-limit (if (eq lower-limit '*) nil lower-limit))
+			      (upper-limit (if (eq upper-limit '*) nil upper-limit)))
+			 (assert (or (null lower-limit)
+				     (null upper-limit)
+				     (<= lower-limit upper-limit)) ()
+			   "The lower limit must be smaller than the upper limit.")
+			 ;; (warn "upper: ~S, loweR: ~S" upper-limit lower-limit)
 			 (cond
-			  ((and (= lower-limit min) (= upper-limit max))
+			  ((and (null lower-limit) (null upper-limit))
 			   `(typep ,object 'integer))
+			  ((null lower-limit)
+			   `(let ((x ,object))
+			      (and (typep x 'integer) (<= x upper-limit))))
+			  ((and (null upper-limit)
+				(= (1+ movitz:+movitz-most-positive-fixnum+) lower-limit))
+			   `(with-inline-assembly-case ()
+			      (do-case (t :boolean-zf=1 :labels (plusp-ok))
+				(:compile-form (:result-mode :eax) ,object)
+				(:leal (:eax ,(- (movitz:tag :other))) :ecx)
+				(:testb 7 :cl)
+				(:jnz 'plusp-ok)
+				(:cmpw ,(movitz:tag :bignum 0)
+				       (:eax ,movitz:+other-type-offset+))
+			       plusp-ok)))
+			  ((and (null upper-limit) (= 0 lower-limit))
+			   `(with-inline-assembly-case ()
+			      (do-case (t :boolean-zf=1 :labels (plusp-ok))
+				(:compile-form (:result-mode :eax) ,object)
+				(:testl ,(logxor #xffffffff
+						 (ash movitz:+movitz-most-positive-fixnum+
+						      movitz:+movitz-fixnum-shift+))
+					:eax)
+				(:jz 'plusp-ok)
+				(:leal (:eax ,(- (movitz:tag :other))) :ecx)
+				(:testb 7 :cl)
+				(:jnz 'plusp-ok)
+				(:cmpw ,(movitz:tag :bignum 0)
+				       (:eax ,movitz:+other-type-offset+))
+			       plusp-ok)))
+			  ((null upper-limit)
+			   `(let ((x ,object))
+			      (and (typep x 'integer) (>= x ,lower-limit))))
 			  ((= lower-limit upper-limit)
 			   `(eql ,object ,lower-limit))
+			  ((or (not (<= movitz:+movitz-most-negative-fixnum+
+					upper-limit
+					movitz:+movitz-most-positive-fixnum+))
+			       (not (<= movitz:+movitz-most-negative-fixnum+
+					lower-limit
+					movitz:+movitz-most-positive-fixnum+)))
+			   `(let ((x ,object))
+			      (and (typep x 'integer)
+				   (<= ,lower-limit x ,upper-limit))))
 			  ((and (= lower-limit 0)
 				(= 1 (logcount (1+ upper-limit))))
 			   `(with-inline-assembly (:returns :boolean-zf=1)




From ffjeld at common-lisp.net  Mon May 24 14:59:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:59:09 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1BSGuz-0000r4-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:59:08 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.10 movitz/losp/muerte/los-closette.lisp:1.11
--- movitz/losp/muerte/los-closette.lisp:1.10	Wed Apr 21 11:07:27 2004
+++ movitz/losp/muerte/los-closette.lisp	Mon May 24 10:59:08 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.10 2004/04/21 15:07:27 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.11 2004/05/24 14:59:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -908,7 +908,7 @@
     (assert slot (slot-name)
       "No slot named ~S in class ~S." slot-name class)
     (let ((slot-location (slot-definition-location slot)))
-      (check-type slot-location (integer 0 *))
+      (check-type slot-location (integer 0 #xffff))
       (etypecase class
 	(standard-class
 	 (if (and (< slot-location (length *standard-effective-slot-readers*))




From ffjeld at common-lisp.net  Mon May 24 14:59:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 10:59:16 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BSGv6-0000yV-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Starting to add some bignum support.

Date: Mon May 24 10:59:16 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.20 movitz/losp/muerte/arrays.lisp:1.21
--- movitz/losp/muerte/arrays.lisp:1.20	Fri May 21 05:41:58 2004
+++ movitz/losp/muerte/arrays.lisp	Mon May 24 10:59: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.20 2004/05/21 09:41:58 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.21 2004/05/24 14:59:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,34 +204,34 @@
 		(: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)
+		(: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 (length vector)))))
 
-		(:cmpl #.(movitz:vector-type-tag :any-t) :ecx)
+		(: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)
+		(: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
+		(:movb ,(movitz::tag :character) :al) ; character
 		(:jmp 'done)
     
 	       not-character
-		(:cmpl #.(movitz:vector-type-tag :u8) :ecx)
+		(:cmpl ,(movitz:vector-type-tag :u8) :ecx)
 		(:jne 'not-u8)
 		(:movzxb (:eax :ebx 2) :eax) ; u8
-		(:shll #.movitz::+movitz-fixnum-shift+ :eax)
+		(:shll ,movitz::+movitz-fixnum-shift+ :eax)
 		(:jmp 'done)
     
 	       not-u8
-		(:cmpl #.(movitz:vector-type-tag :u16) :ecx)
+		(:cmpl ,(movitz:vector-type-tag :u16) :ecx)
 		(:jne 'not-u16)
 		(:movzxw (:eax (:ebx 2) 2) :eax) ; u16
 		(:jmp 'done)
@@ -265,7 +265,7 @@
 		(:compile-form (:result-mode :ebx) value)
 		(:compile-form (:result-mode :eax) vector)
 
-		(:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
+		(:leal (:eax ,(- (movitz:tag :other))) :ecx)
 		(:testb 7 :cl)
 		(:jnz '(:sub-program ()
 			(:compile-form (:result-mode :ignore)
@@ -273,24 +273,24 @@
 		(:movzxw (:eax ,movitz:+other-type-offset+) :edx)
     
 		(:compile-form (:result-mode :ecx) index)
-		(:testb #.movitz::+movitz-fixnum-zmask+ :cl)
+		(:testb ,movitz::+movitz-fixnum-zmask+ :cl)
 		(:jnz '(:sub-program () (:int 107))) ; index not fixnum
-		(:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx)
-		(:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+		(: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)
+		(: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)
+		(: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)
+		(:cmpl ,(movitz:vector-type-tag :character) :edx)
 		(:jnz 'not-character)
-		(:cmpb #.(movitz:tag :character) :bl)
+		(:cmpb ,(movitz:tag :character) :bl)
 		(:jnz '(:sub-program (not-character-value)
 			(:compile-form (:result-mode :ignore)
 			 (error "Value not character: ~S" value))))
@@ -298,40 +298,46 @@
 		(:jmp 'done)
     
 	       not-character
-		(:cmpl #.(movitz:vector-type-tag :u8) :edx)
+		(:cmpl ,(movitz:vector-type-tag :u8) :edx)
 		(:jnz 'not-u8)
-		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx)
+		(: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)
+		(: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)
+		(:cmpl ,(movitz:vector-type-tag :u16) :edx)
 		(:jnz 'not-u16)
-		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx)
+		(: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)
+		(: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)
+		(:cmpl ,(movitz:vector-type-tag :u32) :edx)
 		(:jnz 'not-u32)
-		(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
+		(:testl ,(ldb (byte 32 0)
+			      (- -1 (* #xffffffff movitz:+movitz-fixnum-factor+)))
+			:ebx)
 		(:jnz '(:sub-program (not-u32-value)
 			(:compile-form (:result-mode :ignore)
 			 (error "Value not (unsigned-byte 32): ~S" value))))
-		(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-		(:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-		(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
+		(:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+		(:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx)
 		(:jmp 'done)
 
 	       not-u32




From ffjeld at common-lisp.net  Mon May 24 19:05:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 15:05:59 -0400
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1BSKlr-0003Dl-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 15:05:59 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.30 movitz/image.lisp:1.31
--- movitz/image.lisp:1.30	Mon May 24 10:58:12 2004
+++ movitz/image.lisp	Mon May 24 15:05:59 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.30 2004/05/24 14:58:12 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.31 2004/05/24 19:05:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -226,7 +226,12 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (normalize-u32-ecx
+   (box-u32-ecx
+    :binary-type code-vector-word
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function)
+   (unbox-u32
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Mon May 24 19:10:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 15:10:14 -0400
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1BSKpy-0003CC-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 15:10:13 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.60 movitz/compiler.lisp:1.61
--- movitz/compiler.lisp:1.60	Mon May 24 10:58:00 2004
+++ movitz/compiler.lisp	Mon May 24 15:10:12 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.60 2004/05/24 14:58:00 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.61 2004/05/24 19:10:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -4788,7 +4788,7 @@
 	   (case (result-mode-type desired-result)
 	     ((:eax :single-value)
 	      (values (append code
-			      `((:call (:edi ,(global-constant-offset 'normalize-u32-ecx)))))
+			      `((:call (:edi ,(global-constant-offset 'box-u32-ecx)))))
 		      desired-result))
 	     (t (make-result-and-returns-glue desired-result :eax
 					      (make-result-and-returns-glue :eax :untagged-fixnum-ecx code




From ffjeld at common-lisp.net  Mon May 24 19:32:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 15:32:46 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1BSLBm-00048W-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 15:32:46 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.11 movitz/losp/los0-gc.lisp:1.12
--- movitz/losp/los0-gc.lisp:1.11	Mon May 24 10:58:34 2004
+++ movitz/losp/los0-gc.lisp	Mon May 24 15:32:46 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.11 2004/05/24 14:58:34 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.12 2004/05/24 19:32:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,7 +72,7 @@
     (:movl :ecx (:edx 2))
     (:ret)))
 
-(define-primitive-function los0-normalize-u32-ecx ()
+(define-primitive-function los0-box-u32-ecx ()
   "Make u32 in ECX into a fixnum or bignum."
   (macrolet
       ((do-it ()
@@ -157,9 +157,9 @@
     (check-type conser vector)
     (setf (%run-time-context-slot 'muerte::fast-cons)
       conser))
-  (let ((conser (symbol-value 'los0-normalize-u32-ecx)))
+  (let ((conser (symbol-value 'los0-box-u32-ecx)))
     (check-type conser vector)
-    (setf (%run-time-context-slot 'muerte::normalize-u32-ecx)
+    (setf (%run-time-context-slot 'muerte::box-u32-ecx)
       conser))
   (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
     (setf (symbol-function 'muerte:malloc-clumps)




From ffjeld at common-lisp.net  Mon May 24 19:34:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 15:34:34 -0400
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1BSLDW-0000Po-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 15:34:34 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.18 movitz/losp/muerte/primitive-functions.lisp:1.19
--- movitz/losp/muerte/primitive-functions.lisp:1.18	Mon May 24 10:58:56 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Mon May 24 15:34:34 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.18 2004/05/24 14:58:56 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.19 2004/05/24 19:34:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -505,8 +505,8 @@
     (:ret)))
 
 
-(define-primitive-function normalize-u32-ecx ()
-  "Make u32 in ECX into a fixnum or bignum."
+(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)
@@ -514,6 +514,32 @@
     (:ret)
    not-fixnum
     (:int 107)))			; not implemented by default!
+
+(define-primitive-function unbox-u32 ()
+  "Coerce EAX into a u32 in ECX, or signal type error.
+Preserve EAX, EBX, and EDX."
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :multiple-values)
+	    (:testl ,(logior #x80000000 movitz:+movitz-fixnum-zmask+)
+		    :eax)
+	    (:jnz 'not-fixnum)
+	    (:movl :eax :ecx)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:ret)
+	   not-fixnum
+	    (:leal (:eax ,(- (movitz:tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jnz 'fail)
+	    (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+		   (:eax ,movitz:+other-type-offset+))
+	    (:jne 'fail)
+	    (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+		   :ecx)
+	    (:ret)
+	   fail
+	    (:int 107))))
+    (do-it)))
 
 ;;;;
 




From ffjeld at common-lisp.net  Mon May 24 21:51:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 17:51:52 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1BSNMO-0007RQ-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 17:51:52 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.21 movitz/losp/muerte/arrays.lisp:1.22
--- movitz/losp/muerte/arrays.lisp:1.21	Mon May 24 10:59:15 2004
+++ movitz/losp/muerte/arrays.lisp	Mon May 24 17:51: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.21 2004/05/24 14:59:15 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.22 2004/05/24 21:51:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -240,10 +240,7 @@
 		(:cmpl ,(movitz:vector-type-tag :u32) :ecx)
 		(:jne 'not-u32)
 		(:movl (:eax (:ebx 4) 2) :ecx) ; u32
-		(:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx)
-		(:jg '(:sub-program (:overflowing-u32)
-		       (:int 107)))
-		(:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+		(:call-global-constant box-u32-ecx)
 		(:jmp 'done)
 
 	       not-u32
@@ -329,15 +326,13 @@
 	       not-u16
 		(:cmpl ,(movitz:vector-type-tag :u32) :edx)
 		(:jnz 'not-u32)
-		(:testl ,(ldb (byte 32 0)
-			      (- -1 (* #xffffffff movitz:+movitz-fixnum-factor+)))
-			:ebx)
-		(:jnz '(:sub-program (not-u32-value)
-			(:compile-form (:result-mode :ignore)
-			 (error "Value not (unsigned-byte 32): ~S" value))))
-		(:shrl ,movitz:+movitz-fixnum-shift+ :ebx)
-		(:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-		(:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx)
+		;; 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




From ffjeld at common-lisp.net  Mon May 24 22:38:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 24 May 2004 18:38:12 -0400
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1BSO5E-0007AN-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function
box-u32 that does the inverse. Improved aref and (setf aref) of
u32-vectors accordingly.

Date: Mon May 24 18:38:10 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.11 movitz/losp/muerte/integers.lisp:1.12
--- movitz/losp/muerte/integers.lisp:1.11	Mon May 24 10:58:51 2004
+++ movitz/losp/muerte/integers.lisp	Mon May 24 18:38: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.11 2004/05/24 14:58:51 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.12 2004/05/24 22:38:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -807,7 +807,7 @@
 	     (:movl :edi :eax)
 	     (:cld)
 	     (:pushl :edx)
-	     (:call-global-constant normalize-u32-ecx)
+	     (:call-global-constant box-u32-ecx)
 	     (:popl :ebx)
 	     (:jmp 'done)
 	    not-size1
@@ -827,7 +827,7 @@
 	     (:movl :edi :eax)
 	     (:cld)
 	     (:pushl :edx)
-	     (:call-global-constant normalize-u32-ecx)
+	     (:call-global-constant box-u32-ecx)
 	     (:popl :ebx)
 	     (:jmp 'done)
 	    not-size2