CMUCL commit: amd64-dd-branch src/tools/cross-scripts (cross-x86-amd64.lisp)

[Raymond Toy]

    Date: Tuesday, November 3, 2009 @ 23:26:34
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/tools/cross-scripts
     Tag: amd64-dd-branch

Modified: cross-x86-amd64.lisp

More bootstrapping stuff.  Not sure these are all needed, but they
help cross-compiling quite a bit.


----------------------+
 cross-x86-amd64.lisp |   86 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)


Index: src/tools/cross-scripts/cross-x86-amd64.lisp
diff -u src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.2 src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.3
--- src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.2	Mon Nov  2 10:53:00 2009
+++ src/tools/cross-scripts/cross-x86-amd64.lisp	Tue Nov  3 23:26:34 2009
@@ -135,8 +135,70 @@
 (defconstant char-bytes (truncate char-bits byte-bits)
   "Number of bytes needed to represent a character")
 
+(defconstant target-most-positive-fixnum (1- (ash 1 61)))
+(defconstant target-most-negative-fixnum (ash -1 61))
+
+(defconstant most-positive-fixnum #.vm::target-most-positive-fixnum
+  "The fixnum closest in value to positive infinity.")
+
+(defconstant most-negative-fixnum #.vm::target-most-negative-fixnum
+  "The fixnum closest in value to negative infinity.")
+
+(deftype c::non-negative-fixnum () '(unsigned-byte 61))
 (export '(byte-bits char-bits char-bytes) "VM")
 
+(in-package "KERNEL")
+(define-type-method (number :unparse) (type)
+  (let* ((complexp (numeric-type-complexp type))
+	 (low (numeric-type-low type))
+	 (high (numeric-type-high type))
+	 (base (case (numeric-type-class type)
+		 (integer 'integer)
+		 (rational 'rational)
+		 (float (or (numeric-type-format type) 'float))
+		 (t 'real))))
+    (let ((base+bounds
+	   (cond ((and (eq base 'integer) high low)
+		  (let ((high-count (logcount high))
+			(high-length (integer-length high)))
+		    (cond ((= low 0)
+			   (cond ((= high 0) '(integer 0 0))
+				 ((= high 1) 'bit)
+				 ((and (= high-count high-length)
+				       (plusp high-length))
+				  `(unsigned-byte ,high-length))
+				 (t
+				  `(mod ,(1+ high)))))
+			  ((and (= low vm::target-most-negative-fixnum)
+				(= high vm::target-most-positive-fixnum))
+			   'fixnum)
+			  ((and (= low (lognot high))
+				(= high-count high-length)
+				(> high-count 0))
+			   `(signed-byte ,(1+ high-length)))
+			  (t
+			   `(integer ,low ,high)))))
+		 (high `(,base ,(or low '*) ,high))
+		 (low
+		  (if (and (eq base 'integer) (= low 0))
+		      'unsigned-byte
+		      `(,base ,low)))
+		 (t base))))
+      (ecase complexp
+	(:real
+	 base+bounds)
+	(:complex
+	 (if (eq base+bounds 'real)
+	     'complex
+	     `(complex ,base+bounds)))
+	((nil)
+	 (assert (eq base+bounds 'real))
+	 'number)))))
+(setf (type-class-unparse (type-class-info (c::specifier-type 'fixnum)))
+      #'kernel::number-unparse-type-method)
+
+(c::clear-info c::type c::builtin 'fixnum)
+
 (in-package :cl-user)
 
 (load "target:tools/comcom")
@@ -305,3 +367,27 @@
   (setf (gethash 'old-x86::any-reg ht)
 	(gethash 'amd64::any-reg ht)))
 
+
+(deftype c::non-negative-fixnum () '(unsigned-byte 61))
+
+(describe (c::info c::type c::builtin 'fixnum))
+
+(c::values-specifier-type-cache-clear)
+
+(c::clear-info c::type c::builtin 'fixnum)
+(setf (c::info c::type c::builtin 'fixnum)
+      (c::make-numeric-type :class 'integer
+			    :low (ash -1 61)
+			    :high (1- (ash 1 61))))
+
+(describe (c::info c::type c::builtin 'fixnum))
+(setf (c::backend-type-predicates c::*target-backend*)
+      (acons (c::make-numeric-type :class 'integer
+				   :low (ash -1 61)
+				   :high (1- (ash 1 61)))
+	     'fixnump
+	     (c::backend-type-predicates c::*target-backend*)))
+      
+;;(deftype kernel::index () '(unsigned-byte 61))
+(deftype c::non-negative-fixnum () '(unsigned-byte 61))
+