DRAFT: Add immediate floats (iflos).

libguile/evalext.c

@@ -67,6 +67,9 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
   switch (SCM_ITAG3 (obj))
     {
     case scm_tcs_fixnums:
+#ifdef scm_tcs_iflo
+    case scm_tcs_iflo:
+#endif
       /* immediate numbers */
       return SCM_BOOL_T;
     case scm_tc3_imm24:

libguile/goops.c

@@ -208,6 +208,11 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
     case scm_tcs_fixnums:
       return class_integer;
 
+#ifdef scm_tcs_iflo
+    case scm_tcs_iflo:
+      return class_real;
+#endif
+
     case scm_tc3_imm24:
       if (SCM_CHARP (x))
 	return class_char;

libguile/numbers.c

@@ -653,14 +653,24 @@ scm_i_fraction2double (SCM z)
 static SCM
 scm_i_from_double (double val)
 {
-  SCM z;
+  union { double f64; uint64_t u64; } u;
+  uint64_t bits;
+  SCM result;
 
-  z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+  u.f64 = val;
+  bits = u.u64 + 0x1010000000000000;
+  bits = (bits << 4) | (bits >> 60);
+  result = SCM_PACK (bits);
 
-  SCM_SET_CELL_TYPE (z, scm_tc16_real);
+  if (!SCM_I_IFLO_P (result))
-  SCM_REAL_VALUE (z) = val;
+  {
+    result = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
 
-  return z;
+    SCM_SET_CELL_TYPE (result, scm_tc16_real);
+    ((scm_t_double *) SCM2PTR (result))->real = val;
+  }
+
+  return result;
 }
 
 SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0, 

libguile/numbers.h

@@ -85,6 +85,15 @@ typedef long scm_t_inum;
 #define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
 #define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n))
 
+/* Immediate doubles with exponent <= 255 */
+#define SCM_I_IFLO(x)                                         \
+  ((const union { double _f; uint64_t _u; })                  \
+   { ._u = (((SCM_UNPACK (x) >> 4) | (SCM_UNPACK (x) << 60))  \
+            - 0x1010000000000000) } ._f)
+
+#define SCM_I_IFLO_P(x) (((SCM_UNPACK (x) + 2) & 7) > 2)
+#define SCM_MOST_POSITIVE_IFLO 0x1.fffffffffffffp255 /* 1.1579208923731618e77 */
+#define SCM_MOST_NEGATIVE_IFLO (-SCM_MOST_POSITIVE_IFLO)
 
 #define SCM_INUM0 (SCM_I_MAKINUM (0))  /* A name for 0 */
 #define SCM_INUM1 (SCM_I_MAKINUM (1))  /* A name for 1 */
@@ -141,13 +150,16 @@ typedef long scm_t_inum;
 #define scm_tc16_fraction      (scm_tc11_number + (4 << 12))
 
 #define SCM_INEXACTP(x)                                             \
-  (SCM_NIMP (x)                                                    \
+  (SCM_IMP (x)                                                      \
-    && ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex))  \
+   ? SCM_I_IFLO_P (x)                                               \
+   : ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex))         \
       == (scm_tc16_real & scm_tc16_complex)))
-#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
+#define SCM_REALP(x) \
+  (SCM_IMP (x) ? SCM_I_IFLO_P (x) : SCM_HAS_TYP16 (x, scm_tc16_real))
 #define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
 
-#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
+#define SCM_REAL_VALUE(x) \
+  (SCM_IMP (x) ? SCM_I_IFLO(x) : (((scm_t_double *) SCM2PTR (x))->real))
 #define SCM_COMPLEX_REAL(x) (((scm_t_complex *) SCM2PTR (x))->real)
 #define SCM_COMPLEX_IMAG(x) (((scm_t_complex *) SCM2PTR (x))->imag)
 
@@ -155,7 +167,8 @@ typedef long scm_t_inum;
 #define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
 #define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
 
-#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
+#define SCM_NUMBERP(x) \
+  (SCM_IMP (x) ? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) : SCM_NUMP(x))
 #define SCM_NUMP(x) (SCM_HAS_TYP11 (x, scm_tc11_number))
 
 #define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction))

libguile/print.c

@@ -596,6 +596,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
     case scm_tcs_fixnums:
       scm_intprint (SCM_I_INUM (exp), 10, port);
       break;
+#ifdef scm_tcs_iflo
+    case scm_tcs_iflo:
+      scm_print_real (exp, port, pstate);
+      break;
+#endif
     case scm_tc3_imm24:
       if (SCM_CHARP (exp))
 	{

libguile/random.c

@@ -552,9 +552,10 @@ vector_scale_x (SCM v, double c)
         }
       else if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
         {
+          SCM cc = scm_from_double (c);
           SCM *elts = (SCM *)(handle.writable_elements) + handle.base;
           for (i = dims[0].lbnd; i <= ubnd; ++i, elts += inc)
-            SCM_REAL_VALUE (*elts) *= c;
+            *elts = scm_product (*elts, cc);
           return;
         }
     }

libguile/scm.h

@@ -449,6 +449,7 @@ typedef uintptr_t scm_t_bits;
 #define scm_tc3_cons		 0
 #define scm_tc3_imm24		 6
 #define scm_tcs_fixnums		 7
+#define scm_tcs_iflo		 1: case 2: case 3: case 4: case 5
 
 
 /* Definitions for tc4: */

module/system/base/types.scm

@@ -348,6 +348,15 @@ TYPE-NUMBER."
                                          (dereference-word backend address)))
                    address))
 
+(define (inferior-iflo bits)
+  (let ((dbl-bits (modulo (- (rotate-bit-field bits -4 0 64)
+                             (ash 1 60)
+                             (ash 1 52))
+                          (ash 1 64)))
+        (bv (make-bytevector 8)))
+    (bytevector-u64-native-set! bv 0 dbl-bits)
+    (bytevector-ieee-double-native-ref bv 0)))
+
 (define %visited-cells
   ;; Vhash of mapping addresses of already visited cells to the
   ;; corresponding inferior object.  This is used to detect and represent
@@ -538,7 +547,12 @@ object."
     ((= %tc16-true) #t)
     ((= %tc16-unspecified) (if #f #f))
     ((= %tc16-undefined) (inferior-object 'undefined bits))
-    ((= %tc16-eof) (eof-object))))
+    ((= %tc16-eof) (eof-object))
+    ((_ & 7 = 1) (inferior-iflo bits))  ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+    ((_ & 7 = 2) (inferior-iflo bits))
+    ((_ & 7 = 3) (inferior-iflo bits))
+    ((_ & 7 = 4) (inferior-iflo bits))
+    ((_ & 7 = 5) (inferior-iflo bits))))
 
 ;;; Local Variables:
 ;;; eval: (put 'match-scm 'scheme-indent-function 1)

module/system/vm/assembler.scm

@@ -58,6 +58,7 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-60)
   #:export (make-assembler
 
             (emit-receive* . emit-receive)
@@ -1095,10 +1096,24 @@ lists.  This procedure can be called many times before calling
 ;;; to the table.
 ;;;
 
+(define (double-repl x)
+  (let ((bv (make-bytevector 8)))
+    (bytevector-ieee-double-native-set! bv 0 x)
+    (bytevector-u64-native-ref bv 0)))
+
+;; TAGS-SENSITIVE
+(define (pack-iflo x)
+  (let* ((dbl-bits (double-repl x))
+         (bits (rotate-bit-field (logand (+ (ash 1 60) (ash 1 52) dbl-bits)
+                                         (lognot (ash -1 64)))
+                                 4 0 64)))
+    (and (< 0 (logand bits 7) 6)
+         bits)))
+
 (define (immediate-bits asm x)
   "Return the bit pattern to write into the buffer if @var{x} is
 immediate, and @code{#f} otherwise."
-  (if (exact-integer? x)
+  (cond ((exact-integer? x)
          ;; Object is an immediate if it is a fixnum on the target.
          (call-with-values (lambda ()
                              (case (asm-word-size asm)
@@ -1117,7 +1132,14 @@ immediate, and @code{#f} otherwise."
                   (let ((fixint-bits (if (negative? x)
                                          (+ fixint-max 1 (logand x fixint-max))
                                          x)))
-                 (logior (ash fixint-bits fixint-shift) fixint-tag)))))
+                    (logior (ash fixint-bits fixint-shift) fixint-tag))))))
+        ((and (number? x) (inexact? x) (real? x))
+         (case (asm-word-size asm)
+           ;; TAGS-SENSITIVE
+           ((4) #f)
+           ((8) (pack-iflo x))
+           (else (error "unexpected word size"))))
+        (else
          ;; Otherwise, the object will be immediate on the target if and
          ;; only if it is immediate on the host.  Except for integers,
          ;; which we handle specially above, any immediate value is an
@@ -1128,7 +1150,7 @@ immediate, and @code{#f} otherwise."
          (let ((bits (object-address x)))
            ;; TAGS-SENSITIVE
            (and (not (= (logand bits 7) %tc3-heap-object))
-             bits))))
+                bits)))))
 
 (define-record-type <stringbuf>
   (make-stringbuf string)

test-suite/standalone/test-conversion.c

@@ -867,7 +867,7 @@ test_from_double ()
   test_9 (0.1, "0.1");
   test_9 (guile_Inf, "+inf.0");
   test_9 (-guile_Inf, "-inf.0");
-  test_9 (guile_NaN, "+nan.0");
+  /*  test_9 (guile_NaN, "+nan.0"); */    /* XXXXXXXXXXXXXXXXXX This test is not robust, because it compares NaNs with 'eqv?' */
 }
 
 typedef struct {

test-suite/tests/numbers.test

@@ -140,8 +140,9 @@
 
 ;; Auxiliary predicate used by test-eqv?
 (define (test-real-eqv? x y)
-  (cond ((or (exact? x) (nan? x) (inf? x))
+  (cond ((or (exact? x) (inf? x))
 	 (eqv? x y))
+        ((nan? x) (nan? y))
 	(else (and (inexact? y) (> test-epsilon (abs (- x y)))))))
 
 ;; return true if OBJ is a real NaN

test-suite/tests/srcprop.test

@@ -44,7 +44,7 @@
     (pass-if "strings"         (reads-with-srcprops? "\"hello\""))
     (pass-if "null string"     (reads-with-srcprops? "\"\""))
 
-    (pass-if "floats"          (reads-with-srcprops? "3.1415"))
+    (pass-if "floats"          (reads-with-srcprops? "3.1415e200"))
     (pass-if "fractions"       (reads-with-srcprops? "1/2"))
     (pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
     (pass-if "bignums"

test-suite/tests/srfi-105.test

@@ -184,7 +184,7 @@
     (pass-if "singleton curly-infix list"
       (let ((sexp (with-read-options '(curly-infix positions)
                     (lambda ()
-                      (read-string " { 1.0 }")))))
+                      (read-string " { 1e200 }")))))
         (and (equal? (source-property sexp 'line) 0)
              (equal? (source-property sexp 'column) 3))))
     (pass-if "neoteric expression"