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 3d7636848ee0811c516a0be6146284cea444d197..6d3bbf2a384fadef281268d48c72e80b78ad5d1a 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,7 +29,12 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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))
-
+\f
 (define (bytevector-fill! bytevector fill #!optional start end)
   ((ucode-primitive bytevector-fill! 4)
    bytevector
@@ -157,103 +162,142 @@ USA.
 \f
 ;;;; 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)))))
-\f
-(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))))
+\f
+(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!))
 \f
 (define-integrable (string-encoder char-byte-length allocator encode-char!
                                   caller)

diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index 9d88f5a10f04947779eb0888648bb35bd9d5e050..475f984324c5a9a84fc4461f9156c46b606b25cd 100644 (file)
--- 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)))
 \f
+(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)
+\f
 ;;;; Flonums
 
 (define-primitives

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index eed707df46316ec8cfab98b4852a6f7c5537eef7..12e4d433637b2660eb9ef69a6bd56e301802e319 100644 (file)
--- 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 e9b620cd92283de3babb4f39182f1b2201bd99e0..bf7278549d36be5d6dc37a9196f19f5e161ef8b9 100644 (file)
--- 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 b0faacb280446639ef135569fd34da07d210f14c..d2de1e891ebb1f1b7f9dbf26c0c458789bf448cd 100644 (file)
--- a/tests/runtime/test-bytevector.scm
+++ b/tests/runtime/test-bytevector.scm
@@ -254,6 +254,13 @@ USA.
              (+ (* (cadr bytes) #x100)
                 (car bytes)))))
 \f
+(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)))