diff --git a/libguile/evalext.c b/libguile/evalext.c
index a9366f63b..ef84807a4 100644
--- a/libguile/evalext.c
+++ b/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:
diff --git a/libguile/goops.c b/libguile/goops.c
index 17160d483..eb71130aa 100644
--- a/libguile/goops.c
+++ b/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;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index d1b463358..9f9facef0 100644
--- a/libguile/numbers.c
+++ b/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);
-  SCM_REAL_VALUE (z) = val;
+  if (!SCM_I_IFLO_P (result))
+  {
+    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, 
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 0aa35337c..0d9253af1 100644
--- a/libguile/numbers.h
+++ b/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 */
@@ -140,14 +149,17 @@ typedef long scm_t_inum;
 #define scm_tc16_complex       (scm_tc11_number + (3 << 12))
 #define scm_tc16_fraction      (scm_tc11_number + (4 << 12))
 
-#define SCM_INEXACTP(x)                                            \
-  (SCM_NIMP (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_INEXACTP(x)                                             \
+  (SCM_IMP (x)                                                      \
+   ? 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_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))
diff --git a/libguile/print.c b/libguile/print.c
index ce46243b3..7e050989d 100644
--- a/libguile/print.c
+++ b/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))
 	{
diff --git a/libguile/random.c b/libguile/random.c
index 6fd567cca..a7b9c56d6 100644
--- a/libguile/random.c
+++ b/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;
         }
     }
diff --git a/libguile/scm.h b/libguile/scm.h
index 6c7913f6f..6b229dde6 100644
--- a/libguile/scm.h
+++ b/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: */
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 5a9d4d765..ee62a5e0c 100644
--- a/module/system/base/types.scm
+++ b/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)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index a45ded8a5..c23a665b4 100644
--- a/module/system/vm/assembler.scm
+++ b/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,40 +1096,61 @@ 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)
-      ;; Object is an immediate if it is a fixnum on the target.
-      (call-with-values (lambda ()
-                          (case (asm-word-size asm)
-                            ;; TAGS-SENSITIVE
-                            ((4) (values    #x-40000000
-                                            #x3fffffff
-                                            1   ;fixint tag
-                                            1)) ;fixint shift
-                            ((8) (values    #x-800000000000000
-                                            #x7ffffffFFFFFFFF
-                                            15  ;fixint tag
-                                            4)) ;fixint shift
-                            (else (error "unexpected word size"))))
-        (lambda (fixint-min fixint-max fixint-tag fixint-shift)
-          (and (<= fixint-min x fixint-max)
-               (let ((fixint-bits (if (negative? x)
-                                      (+ fixint-max 1 (logand x fixint-max))
-                                      x)))
-                 (logior (ash fixint-bits fixint-shift) fixint-tag)))))
-      ;; 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
-      ;; immediate on both 32-bit and 64-bit targets.
-      ;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
-      ;; XXX in the new tagging scheme, the following will rarely if
-      ;; ever be sufficient when cross-compiling.
-      (let ((bits (object-address x)))
-        ;; TAGS-SENSITIVE
-        (and (not (= (logand bits 7) %tc3-heap-object))
-             bits))))
+  (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)
+                               ;; TAGS-SENSITIVE
+                               ((4) (values    #x-40000000
+                                               #x3fffffff
+                                               1   ;fixint tag
+                                               1)) ;fixint shift
+                               ((8) (values    #x-800000000000000
+                                               #x7ffffffFFFFFFFF
+                                               15  ;fixint tag
+                                               4)) ;fixint shift
+                               (else (error "unexpected word size"))))
+           (lambda (fixint-min fixint-max fixint-tag fixint-shift)
+             (and (<= fixint-min x fixint-max)
+                  (let ((fixint-bits (if (negative? x)
+                                         (+ fixint-max 1 (logand x fixint-max))
+                                         x)))
+                    (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
+         ;; immediate on both 32-bit and 64-bit targets.
+         ;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+         ;; XXX in the new tagging scheme, the following will rarely if
+         ;; ever be sufficient when cross-compiling.
+         (let ((bits (object-address x)))
+           ;; TAGS-SENSITIVE
+           (and (not (= (logand bits 7) %tc3-heap-object))
+                bits)))))
 
 (define-record-type <stringbuf>
   (make-stringbuf string)
diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c
index 6e3ec6cdd..5e56d2ce7 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/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 {
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 59e370ec9..662327f22 100644
--- a/test-suite/tests/numbers.test
+++ b/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
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 4afc31802..a14cd1e44 100644
--- a/test-suite/tests/srcprop.test
+++ b/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"
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
index d212bd084..31fd501dc 100644
--- a/test-suite/tests/srfi-105.test
+++ b/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"