floats: add operators to convert between floats and bits (integers)

The interface is in the system package (that is - not part of the official api).

src/c/num_co.d

@@ -476,3 +476,31 @@ cl_imagpart(cl_object x)
   }
   @(return x);
 }
+
+uint32_t
+ecl_float_bits(float num)
+{
+  union { float f; uint32_t u; } fu = { .f = num };
+  return fu.u;
+}
+
+uint64_t
+ecl_double_bits(double num)
+{
+  union { double f; uint64_t u; } fu = { .f = num };
+  return fu.u;
+}
+
+float
+ecl_bits_float(uint32_t num)
+{
+  union { float f; uint32_t u; } fu = { .u = num };
+  return fu.f;
+}
+
+double
+ecl_bits_double(uint64_t num)
+{
+  union { double f; uint64_t u; } fu = { .u = num };
+  return fu.f;
+}

src/c/symbols_list.h

@@ -1992,6 +1992,13 @@ cl_symbols[] = {
 {EXT_ "FLOAT-NAN-STRING" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
 {EXT_ "FLOAT-INFINITY-STRING" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
 
+{SYS_ "SINGLE-FLOAT-BITS" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "BITS-SINGLE-FLOAT" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "DOUBLE-FLOAT-BITS" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "BITS-DOUBLE-FLOAT" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "LONG-FLOAT-BITS" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "BITS-LONG-FLOAT" ECL_FUN(NULL, NULL, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+
 {SYS_ "READ-OBJECT-OR-IGNORE" ECL_FUN("si_read_object_or_ignore", si_read_object_or_ignore, 2) ECL_VAR(EXT_ORDINARY, OBJNULL)},
 
 {EXT_ "READTABLE-LOCK" ECL_FUN("si_readtable_lock", si_readtable_lock, -2) ECL_VAR(EXT_ORDINARY, OBJNULL)},

src/cmp/proclamations.lsp

@@ -618,6 +618,13 @@
 #+complex-float (proclamation si:complex-float (float float) si:complex-float :pure)
 #+complex-float (proclamation si:complex-float-p (t) gen-bool :pure)
 
+(proclamation si:single-float-bits (single-float) integer :pure)
+(proclamation si:bits-single-float (integer) single-float :pure)
+(proclamation si:double-float-bits (double-float) integer :pure)
+(proclamation si:bits-double-float (integer) double-float :pure)
+(proclamation si:long-float-bits (long-float) integer :pure)
+(proclamation si:bits-long-float (integer) long-float :pure)
+
 ;; Virtual functions added by the compiler
 (proclamation shift>> (*) nil :pure)
 (proclamation shift<< (*) nil :pure)

src/h/external.h

@@ -1197,6 +1197,10 @@ extern ECL_API cl_object ecl_ceiling2(cl_object x, cl_object y);
 extern ECL_API cl_object ecl_truncate2(cl_object x, cl_object y);
 extern ECL_API cl_object ecl_round2(cl_object x, cl_object y);
 
+extern ECL_API uint32_t ecl_float_bits(float num);
+extern ECL_API float    ecl_bits_float(uint32_t num);
+extern ECL_API uint64_t ecl_double_bits(double num);
+extern ECL_API double   ecl_bits_double(uint64_t num);
 
 /* num_comp.c */
 

src/lsp/numlib.lsp

@@ -427,3 +427,26 @@ specified bits of INTEGER2 with the specified bits of INTEGER1."
          (mask (ash (lognot (ash -1 size)) pos)))
     (logior (logandc2 integer mask)
             (logand newbyte mask))))
+
+(defun single-float-bits (num)
+  (ffi:c-inline (num) (:float) :uint32-t "ecl_float_bits(#0)" :one-liner t))
+
+(defun bits-single-float (num)
+  (ffi:c-inline (num) (:uint32-t) :float "ecl_bits_float(#0)" :one-liner t))
+
+(defun double-float-bits (num)
+  (ffi:c-inline (num) (:double) :uint64-t "ecl_double_bits(#0)" :one-liner t))
+
+(defun bits-double-float (num)
+  (ffi:c-inline (num) (:uint64-t) :double "ecl_bits_double(#0)" :one-liner t))
+
+;;; XXX long double may have 64, 80, 96 or 128 bits (possibly more). The layout
+;;; in the memory is also an unknown, so we punt here. -- jd 2022-07-07
+
+(defun long-float-bits (num)
+  #+long-float (error "Operation not supported.")
+  #-long-float (double-float-bits num))
+
+(defun bits-long-float (num)
+  #+long-float (error "Operation not supported.")
+  #-long-float (bits-double-float num))

src/tests/normal-tests/ieee-fp.lsp

@@ -782,3 +782,12 @@ Common Lisp type contagion rules."
           (z-below (complex x -0.0)))
       (is (plusp (imagpart (sqrt z-above))))
       (is (minusp (imagpart (sqrt z-below)))))))
+
+(test ieee-fp.0032.bit-conversion/smoke
+  (is (= 3.14 (si:bits-single-float (si:single-float-bits 3.14))))
+  (is (= 3.14 (si:bits-double-float (si:double-float-bits 3.14))))
+  #-long-float
+  (is (= 3.14 (si:bits-long-float (si:long-float-bits 3.14))))
+  #+long-float
+  (progn (signals error (si:long-float-bits 3.14))
+         (signals error (si:bits-long-float 3.14))))