From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 27 Jan 2017 16:17:31 +0000 (-0800)
Subject: Fix bugs: fixnum sizes must be measured at runtime.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~52
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e9e83203ec5a7535b60f54ab5a84cdfccc113f2;p=mit-scheme.git

Fix bugs: fixnum sizes must be measured at runtime.

Otherwise cross-compiling on a host that's wider than the target will not work.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 3d7636848..6d3bbf2a3 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,7 +29,12 @@ USA.
 
 (declare (usual-integrations))
 
-(define (byte? object)
+(define (register-mit-bytevector-predicates!)
+  (register-predicate! u8? 'u8 '<= index-fixnum?)
+  (register-predicate! u16? 'u16 '<= index-fixnum?)
+  (register-predicate! u32? 'u32 '<= exact-nonnegative-integer?))
+
+(define (u8? object)
   (and (index-fixnum? object)
        (fix:< object #x100)))
 
@@ -78,7 +83,7 @@ USA.
 	((not (pair? bytevectors)))
       (bytevector-copy! bytevector index (car bytevectors)))
     bytevector))
-
+
 (define (bytevector-fill! bytevector fill #!optional start end)
   ((ucode-primitive bytevector-fill! 4)
    bytevector
@@ -157,103 +162,142 @@ USA.
 
 ;;;; U32 accessors
 
-(define-syntax select-u32-code
-  (er-macro-transformer
-   (lambda (form rename compare)
-     rename compare
-     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
-     (if (fix:fixnum? #xFFFFFFFF)
-	 (cadr form)
-	 (caddr form)))))
-
-(select-u32-code
- ;; Can use fixnums:
- (begin
-   (define-integrable (bytes->u32be b0 b1 b2 b3)
-     (fix:or (fix:or (fix:lsh b0 24)
-		     (fix:lsh b1 16))
-	     (fix:or (fix:lsh b2 8)
-		     b3)))
-
-   (define-integrable (u32be-byte0 u32) (fix:lsh u32 -24))
-   (define-integrable (u32be-byte1 u32) (fix:and (fix:lsh u32 -16) #xFF))
-   (define-integrable (u32be-byte2 u32) (fix:and (fix:lsh u32 -8) #xFF))
-   (define-integrable (u32be-byte3 u32) (fix:and u32 #xFF))
-
-   (define (u32? object)
-     (and (index-fixnum? object)
-	  (fix:<= object #xFFFFFFFF))))
- ;; Must use bignums:
- (begin
-   (define-integrable (bytes->u32be b0 b1 b2 b3)
-     (int:+ (int:+ (int:* b0 #x1000000)
-		   (int:* b1 #x10000))
-	    (int:+ (int:* b2 #x100)
-		   b3)))
-
-   (define-integrable (u32be-byte0 u32)
-     (int:quotient u32 #x1000000))
-
-   (define-integrable (u32be-byte1 u32)
-     (int:remainder (int:quotient u32 #x10000) #x100))
-
-   (define-integrable (u32be-byte2 u32)
-     (int:remainder (int:quotient u32 #x100) #x100))
-
-   (define-integrable (u32be-byte3 u32)
-     (int:remainder u32 #x100))
-
-   (define (u32? object)
-     (and (exact-nonnegative-integer? object)
-	  (int:<= object #xFFFFFFFF)))))
-
-(define-integrable (bytes->u32le b0 b1 b2 b3) (bytes->u32be b3 b2 b1 b0))
-(define-integrable u32le-byte0 u32be-byte3)
-(define-integrable u32le-byte1 u32be-byte2)
-(define-integrable u32le-byte2 u32be-byte1)
-(define-integrable u32le-byte3 u32be-byte0)
+;;; A lot of trouble to use fixnums if the architecture supports them.  When
+;;; Scheme is started it does the test and chooses the impleemntation.  The
+;;; exported names are fixed so that stashed copies of their values always get
+;;; the current implementation.
 
 (define (bytevector-u32be-ref bytevector index)
-  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-      (error:bad-range-argument index 'bytevector-u32be-ref))
-  (bytes->u32be (bytevector-u8-ref bytevector index)
-		(bytevector-u8-ref bytevector (fix:+ index 1))
-		(bytevector-u8-ref bytevector (fix:+ index 2))
-		(bytevector-u8-ref bytevector (fix:+ index 3))))
+  (%u32be-ref bytevector index))
 
 (define (bytevector-u32be-set! bytevector index u32)
-  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-      (error:bad-range-argument index 'bytevector-u32be-ref))
-  (guarantee u32? u32 'bytevector-u32be-set!)
-  (bytevector-u8-set! bytevector index (u32be-byte0 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 1) (u32be-byte1 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 2) (u32be-byte2 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 3) (u32be-byte3 u32)))
+  (%u32be-set! bytevector index u32))
 
 (define (bytevector-u32le-ref bytevector index)
-  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-      (error:bad-range-argument index 'bytevector-u32le-ref))
-  (bytes->u32le (bytevector-u8-ref bytevector index)
+  (%u32le-ref bytevector index))
+
+(define (bytevector-u32le-set! bytevector index u32)
+  (%u32le-set! bytevector index u32))
+
+(define (u32? object)
+  (%u32? object))
+
+(define %u32?)
+(define %u32be-ref)
+(define %u32be-set!)
+(define %u32le-ref)
+(define %u32le-set!)
+(define (choose-u32-type!)
+  (if (<= #xFFFFFFFF (fix:largest-value))
+      (begin
+	(set! %u32? fix:u32?)
+	(set! %u32be-ref fix:u32be-ref)
+	(set! %u32be-set! fix:u32be-set!)
+	(set! %u32le-ref fix:u32le-ref)
+	(set! %u32le-set! fix:u32le-set!))
+      (begin
+	(set! %u32? int:u32?)
+	(set! %u32be-ref int:u32be-ref)
+	(set! %u32be-set! int:u32be-set!)
+	(set! %u32le-ref int:u32le-ref)
+	(set! %u32le-set! int:u32le-set!)))
+  unspecific)
+
+(add-boot-init!
+ (lambda ()
+   (choose-u32-type!)
+   (add-event-receiver! event:after-restore choose-u32-type!)))
+
+(define-integrable (u32-getter bytes->u32 caller)
+  (lambda (bytevector index)
+    (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+	(error:bad-range-argument index caller))
+    (bytes->u32 (bytevector-u8-ref bytevector index)
 		(bytevector-u8-ref bytevector (fix:+ index 1))
 		(bytevector-u8-ref bytevector (fix:+ index 2))
-		(bytevector-u8-ref bytevector (fix:+ index 3))))
+		(bytevector-u8-ref bytevector (fix:+ index 3)))))
+
+(define-integrable (u32-setter u32-byte0 u32-byte1 u32-byte2 u32-byte3
+			       u32? caller)
+  (lambda (bytevector index u32)
+    (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+	(error:bad-range-argument index caller))
+    (guarantee u32? u32 caller)
+    (bytevector-u8-set! bytevector index (u32-byte0 u32))
+    (bytevector-u8-set! bytevector (fix:+ index 1) (u32-byte1 u32))
+    (bytevector-u8-set! bytevector (fix:+ index 2) (u32-byte2 u32))
+    (bytevector-u8-set! bytevector (fix:+ index 3) (u32-byte3 u32))))
+
+(define-integrable (fix:bytes->u32be b0 b1 b2 b3)
+  (fix:or (fix:or (fix:lsh b0 24)
+		  (fix:lsh b1 16))
+	  (fix:or (fix:lsh b2 8)
+		  b3)))
+
+(define-integrable (fix:u32be-byte0 u32) (fix:lsh u32 -24))
+(define-integrable (fix:u32be-byte1 u32) (fix:and (fix:lsh u32 -16) #xFF))
+(define-integrable (fix:u32be-byte2 u32) (fix:and (fix:lsh u32 -8) #xFF))
+(define-integrable (fix:u32be-byte3 u32) (fix:and u32 #xFF))
+
+(define (fix:u32? object)
+  (and (index-fixnum? object)
+       (fix:<= object #xFFFFFFFF)))
 
-(define (bytevector-u32le-set! bytevector index u32)
-  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-      (error:bad-range-argument index 'bytevector-u32le-ref))
-  (guarantee u32? u32 'bytevector-u32le-set!)
-  (bytevector-u8-set! bytevector index (u32le-byte0 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 1) (u32le-byte1 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 2) (u32le-byte2 u32))
-  (bytevector-u8-set! bytevector (fix:+ index 3) (u32le-byte3 u32)))
+(define-integrable (fix:bytes->u32le b0 b1 b2 b3)
+  (fix:bytes->u32be b3 b2 b1 b0))
 
-(define (register-mit-bytevector-predicates!)
-  (register-predicate! byte? 'byte '<= index-fixnum?)
-  (register-predicate! u16? 'u16 '<= index-fixnum?)
-  (register-predicate! u32? 'u32
-		       '<= (if (fix:fixnum? #xFFFFFFFF)
-			       index-fixnum?
-			       exact-nonnegative-integer?)))
+(define fix:u32be-ref
+  (u32-getter fix:bytes->u32be 'bytevector-u32be-ref))
+
+(define fix:u32be-set!
+  (u32-setter fix:u32be-byte0 fix:u32be-byte1 fix:u32be-byte2 fix:u32be-byte3
+	      fix:u32? 'bytevector-u32be-set!))
+
+(define fix:u32le-ref
+  (u32-getter fix:bytes->u32le 'bytevector-u32le-ref))
+
+(define fix:u32le-set!
+  (u32-setter fix:u32be-byte3 fix:u32be-byte2 fix:u32be-byte1 fix:u32be-byte0
+	      fix:u32? 'bytevector-u32le-set!))
+
+(define-integrable (int:bytes->u32be b0 b1 b2 b3)
+  (int:+ (int:+ (int:* b0 #x1000000)
+		(int:* b1 #x10000))
+	 (int:+ (int:* b2 #x100)
+		b3)))
+
+(define-integrable (int:u32be-byte0 u32)
+  (int:quotient u32 #x1000000))
+
+(define-integrable (int:u32be-byte1 u32)
+  (int:remainder (int:quotient u32 #x10000) #x100))
+
+(define-integrable (int:u32be-byte2 u32)
+  (int:remainder (int:quotient u32 #x100) #x100))
+
+(define-integrable (int:u32be-byte3 u32)
+  (int:remainder u32 #x100))
+
+(define (int:u32? object)
+  (and (exact-nonnegative-integer? object)
+       (int:<= object #xFFFFFFFF)))
+
+(define-integrable (int:bytes->u32le b0 b1 b2 b3)
+  (int:bytes->u32be b3 b2 b1 b0))
+
+(define int:u32be-ref
+  (u32-getter int:bytes->u32be 'bytevector-u32be-ref))
+
+(define int:u32be-set!
+  (u32-setter int:u32be-byte0 int:u32be-byte1 int:u32be-byte2 int:u32be-byte3
+	      int:u32? 'bytevector-u32be-set!))
+
+(define int:u32le-ref
+  (u32-getter int:bytes->u32le 'bytevector-u32le-ref))
+
+(define int:u32le-set!
+  (u32-setter int:u32be-byte3 int:u32be-byte2 int:u32be-byte1 int:u32be-byte0
+	      int:u32? 'bytevector-u32le-set!))
 
 (define-integrable (string-encoder char-byte-length allocator encode-char!
 				   caller)
diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index 9d88f5a10..475f98432 100644
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -93,32 +93,6 @@ USA.
 (define (fix:min n m) (if (fix:< n m) n m))
 (define (fix:max n m) (if (fix:> n m) n m))
 
-(define (fix:largest-value)
-  (force largest-fixnum-promise))
-
-(define largest-fixnum-promise
-  (delay
-    (let loop ((n 1))
-      (if (fix:fixnum? n)
-	  (loop (* n 2))
-	  (let ((n (- n 1)))
-	    (if (not (fix:fixnum? n))
-		(error "Unable to compute largest fixnum:" n))
-	    n)))))
-
-(define (fix:smallest-value)
-  (force smallest-fixnum-promise))
-
-(define smallest-fixnum-promise
-  (delay
-    (let loop ((n -1))
-      (if (fix:fixnum? n)
-	  (loop (* n 2))
-	  (let ((n (quotient n 2)))
-	    (if (not (fix:fixnum? n))
-		(error "Unable to compute smallest fixnum:" n))
-	    n)))))
-
 (define (fix:iota count #!optional start step)
   (guarantee index-fixnum? count 'fix:iota)
   (let ((start
@@ -161,6 +135,37 @@ USA.
 	    (error:bad-range-argument start caller))
 	start)))
 
+(define (fix:largest-value)
+  largest-fixnum-value)
+
+(define (fix:smallest-value)
+  smallest-fixnum-value)
+
+(define (initialize-package!)
+  (initialize-microcode-dependencies!)
+  (add-event-receiver! event:after-restore initialize-microcode-dependencies!))
+
+(define largest-fixnum-value)
+(define smallest-fixnum-value)
+(define (initialize-microcode-dependencies!)
+  (set! largest-fixnum-value
+	(let loop ((n 1))
+	  (if (fix:fixnum? n)
+	      (loop (* n 2))
+	      (let ((n (- n 1)))
+		(if (not (fix:fixnum? n))
+		    (error "Unable to compute largest fixnum:" n))
+		n))))
+  (set! smallest-fixnum-value
+	(let loop ((n -1))
+	  (if (fix:fixnum? n)
+	      (loop (* n 2))
+	      (let ((n (quotient n 2)))
+		(if (not (fix:fixnum? n))
+		    (error "Unable to compute smallest fixnum:" n))
+		n))))
+  unspecific)
+
 ;;;; Flonums
 
 (define-primitives
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index eed707df4..12e4d4336 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -440,6 +440,7 @@ USA.
    ;; Basic data structures
    (RUNTIME NUMBER)
    ((RUNTIME NUMBER) INITIALIZE-DRAGON4!)
+   (RUNTIME FIXNUM-ARITHMETIC)
    (RUNTIME MISCELLANEOUS-GLOBAL)
    (RUNTIME CHARACTER)
    (RUNTIME BYTEVECTOR)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e9b620cd9..bf7278549 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -318,7 +318,8 @@ USA.
 	  negative-fixnum?
 	  non-negative-fixnum?
 	  non-positive-fixnum?
-	  positive-fixnum?))
+	  positive-fixnum?)
+  (initialization (initialize-package!)))
 
 (define-package (runtime floating-point-environment)
   (files "floenv")
@@ -1211,7 +1212,7 @@ USA.
 	  ;; BEGIN deprecated bindings
 	  legacy-string->bytevector
 	  ;; END deprecated bindings
-	  byte?
+	  (byte? u8?)
 	  bytevector
 	  bytevector-append
 	  bytevector-copy
@@ -1239,6 +1240,7 @@ USA.
 	  string->utf8
 	  u16?
 	  u32?
+	  u8?
 	  utf16be->string
 	  utf16le->string
 	  utf32be->string
diff --git a/tests/runtime/test-bytevector.scm b/tests/runtime/test-bytevector.scm
index b0faacb28..d2de1e891 100644
--- a/tests/runtime/test-bytevector.scm
+++ b/tests/runtime/test-bytevector.scm
@@ -254,6 +254,13 @@ USA.
 	      (+ (* (cadr bytes) #x100)
 		 (car bytes)))))
 
+(define-test 'u32-implementation
+  (lambda ()
+    ;; This will fail on 32-bit machines if the wrong implementation is used:
+    (assert-true (u32? #xFFFFFFFF))
+    ;; This should fail for either implementation:
+    (assert-false (u32? #x100000000))))
+
 (define-test 'bytevector-u32-ref
   (lambda ()
     (do ((i 0 (+ i 1)))