[movitz-cvs] CVS update: movitz/storage-types.lisp

[Frode Vatvedt Fjeld]

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))))