quaviver: add byte form traits

s-expressionists · Jun 28, 2024 · be27100 · be27100
1 parent 3eadedd
commit be27100
Show file tree

Hide file tree

Showing 5 changed files with 108 additions and 19 deletions.
diff --git a/code/float-integer-2.lisp b/code/float-integer-2.lisp
@@ -4,32 +4,34 @@
   (with-accessors ((storage-size storage-size)
                    (significand-size significand-size)
                    (significand-bytespec significand-bytespec)
+                   (significand-byte-form significand-byte-form)
                    (exponent-bytespec exponent-bytespec)
-                   (sign-bytespec sign-bytespec)
-                   (nan-payload-bytespec nan-payload-bytespec)
-                   (nan-type-bytespec nan-type-bytespec)
+                   (exponent-byte-form exponent-byte-form)
+                   (sign-byte-form sign-byte-form)
+                   (nan-payload-byte-form nan-payload-byte-form)
+                   (nan-type-byte-form nan-type-byte-form)
                    (hidden-bit-p hidden-bit-p)
                    (exponent-bias exponent-bias))
       type
     `(let* ((bits ,value)
-            (exponent (ldb ',exponent-bytespec bits))
-            (sign (if (ldb-test ',sign-bytespec bits) -1 1)))
+            (exponent (ldb ,exponent-byte-form bits))
+            (sign (if (ldb-test ,sign-byte-form bits) -1 1)))
        (declare (type (unsigned-byte ,storage-size)
                       bits)
                 (type (unsigned-byte ,(byte-size exponent-bytespec))
                       exponent)
                 (type (integer -1 1)
                       sign))
        (cond ((= exponent ,(1- (ash 1 (byte-size exponent-bytespec))))
-              (if (ldb-test ',significand-bytespec bits) ; nan
-                  (values (ldb ',nan-payload-bytespec bits)
-                          (if (ldb-test ',nan-type-bytespec bits)
+              (if (ldb-test ,significand-byte-form bits) ; nan
+                  (values (ldb ,nan-payload-byte-form bits)
+                          (if (ldb-test ,nan-type-byte-form bits)
                               :quiet-nan
                               :signaling-nan)
                           1)
                   (values 0 :infinity sign)))
              (t
-              (let ((significand (ldb ',significand-bytespec bits)))
+              (let ((significand (ldb ,significand-byte-form bits)))
                 (declare (type (unsigned-byte ,(byte-size significand-bytespec))
                                significand))
                 (cond ((and (zerop significand)

diff --git a/code/integer-float-2.lisp b/code/integer-float-2.lisp
@@ -4,10 +4,12 @@
     ((bits-var client type significand exponent sign) &body body)
   (with-accessors ((storage-size storage-size)
                    (significand-bytespec significand-bytespec)
+                   (significand-byte-form significand-byte-form)
                    (exponent-bytespec exponent-bytespec)
-                   (sign-bytespec sign-bytespec)
-                   (nan-payload-bytespec nan-payload-bytespec)
-                   (nan-type-bytespec nan-type-bytespec)
+                   (exponent-byte-form exponent-byte-form)
+                   (sign-byte-form sign-byte-form)
+                   (nan-payload-byte-form nan-payload-byte-form)
+                   (nan-type-byte-form nan-type-byte-form)
                    (hidden-bit-p hidden-bit-p)
                    (exponent-bias exponent-bias)
                    (min-exponent min-exponent)
@@ -24,17 +26,17 @@
            ,@declarations
            (declare (type (unsigned-byte ,storage-size) ,bits-var))
            (when (minusp ,sign)
-             (setf (ldb ',sign-bytespec ,bits-var) 1))
+             (setf (ldb ,sign-byte-form ,bits-var) 1))
            (cond ((keywordp exponent)
-                  (setf (ldb ',exponent-bytespec ,bits-var)
+                  (setf (ldb ,exponent-byte-form ,bits-var)
                         ,(1- (ash 1 (byte-size exponent-bytespec))))
                   (ecase exponent
                     (:infinity)
                     (:quiet-nan
-                     (setf (ldb ',nan-type-bytespec ,bits-var) 1
-                           (ldb ',nan-payload-bytespec ,bits-var) ,significand-var))
+                     (setf (ldb ,nan-type-byte-form ,bits-var) 1
+                           (ldb ,nan-payload-byte-form ,bits-var) ,significand-var))
                     (:signaling-nan
-                     (setf (ldb ',nan-payload-bytespec ,bits-var)
+                     (setf (ldb ,nan-payload-byte-form ,bits-var)
                            (if (zerop ,significand-var) 1 ,significand-var)))))
                  ((zerop ,significand-var))
                  (t
@@ -55,9 +57,9 @@
                         (t
                          (incf ,exponent-var ,exponent-bias)
                          (cond ((plusp ,exponent-var)
-                                (setf (ldb ',significand-bytespec ,bits-var)
+                                (setf (ldb ,significand-byte-form ,bits-var)
                                       ,significand-var
-                                      (ldb ',exponent-bytespec ,bits-var)
+                                      (ldb ,exponent-byte-form ,bits-var)
                                       ,exponent-var))
                                (t ; Unadjusted subnormal
                                 (setf (ldb (byte (+ ,(byte-size significand-bytespec)

diff --git a/code/interface.lisp b/code/interface.lisp
@@ -16,14 +16,24 @@
 
 (defgeneric significand-bytespec (type))
 
+(defgeneric significand-byte-form (type))
+
 (defgeneric exponent-bytespec (type))
 
+(defgeneric exponent-byte-form (type))
+
 (defgeneric sign-bytespec (type))
 
+(defgeneric sign-byte-form (type))
+
 (defgeneric nan-payload-bytespec (type))
 
+(defgeneric nan-payload-byte-form (type))
+
 (defgeneric nan-type-bytespec (type))
 
+(defgeneric nan-type-byte-form (type))
+
 (defgeneric hidden-bit-p (type))
 
 (defgeneric exponent-bias (type))

diff --git a/code/packages.lisp b/code/packages.lisp
@@ -8,10 +8,15 @@
            #:integer-digits
            #:storage-size
            #:significand-bytespec
+           #:significand-byte-form
            #:exponent-bytespec
+           #:exponent-byte-form
            #:sign-bytespec
+           #:sign-byte-form
            #:nan-payload-bytespec
+           #:nan-payload-byte-form
            #:nan-type-bytespec
+           #:nan-type-byte-form
            #:hidden-bit-p
            #:exponent-bias
            #:max-exponent

diff --git a/code/traits.lisp b/code/traits.lisp
@@ -8,22 +8,42 @@
   #+clisp (byte 16 0)
   #-clisp (byte 23 0))
 
+(defmethod significand-byte-form ((type (eql 'short-float)))
+  #+clisp `(byte 16 0)
+  #-clisp `(byte 23 0))
+
 (defmethod exponent-bytespec ((type (eql 'short-float)))
   #+clisp (byte 8 16)
   #-clisp (byte 8 23))
 
+(defmethod exponent-byte-form ((type (eql 'short-float)))
+  #+clisp `(byte 8 16)
+  #-clisp `(byte 8 23))
+
 (defmethod sign-bytespec ((type (eql 'short-float)))
   #+clisp (byte 1 24)
   #-clisp (byte 1 31))
 
+(defmethod sign-byte-form ((type (eql 'short-float)))
+  #+clisp `(byte 1 24)
+  #-clisp `(byte 1 31))
+
 (defmethod nan-payload-bytespec ((type (eql 'short-float)))
   #+clisp (byte 15 0)
   #-clisp (byte 22 0))
 
+(defmethod nan-payload-byte-form ((type (eql 'short-float)))
+  #+clisp `(byte 15 0)
+  #-clisp `(byte 22 0))
+
 (defmethod nan-type-bytespec ((type (eql 'short-float)))
   #+clisp (byte 1 15)
   #-clisp (byte 1 22))
 
+(defmethod nan-type-byte-form ((type (eql 'short-float)))
+  #+clisp `(byte 1 15)
+  #-clisp `(byte 1 22))
+
 (defmethod hidden-bit-p ((type (eql 'short-float)))
   t)
 
@@ -48,18 +68,33 @@
 (defmethod significand-bytespec ((type (eql 'single-float)))
   (byte 23 0))
 
+(defmethod significand-byte-form ((type (eql 'single-float)))
+  `(byte 23 0))
+
 (defmethod exponent-bytespec ((type (eql 'single-float)))
   (byte 8 23))
 
+(defmethod exponent-byte-form ((type (eql 'single-float)))
+  `(byte 8 23))
+
 (defmethod sign-bytespec ((type (eql 'single-float)))
   (byte 1 31))
 
+(defmethod sign-byte-form ((type (eql 'single-float)))
+  `(byte 1 31))
+
 (defmethod nan-payload-bytespec ((type (eql 'single-float)))
   (byte 22 0))
 
+(defmethod nan-payload-byte-form ((type (eql 'single-float)))
+  `(byte 22 0))
+
 (defmethod nan-type-bytespec ((type (eql 'single-float)))
   (byte 1 22))
 
+(defmethod nan-type-byte-form ((type (eql 'single-float)))
+  `(byte 1 22))
+
 (defmethod hidden-bit-p ((type (eql 'single-float)))
   t)
 
@@ -81,18 +116,33 @@
 (defmethod significand-bytespec ((type (eql 'double-float)))
   (byte 52 0))
 
+(defmethod significand-byte-form ((type (eql 'double-float)))
+  `(byte 52 0))
+
 (defmethod exponent-bytespec ((type (eql 'double-float)))
   (byte 11 52))
 
+(defmethod exponent-byte-form ((type (eql 'double-float)))
+  `(byte 11 52))
+
 (defmethod sign-bytespec ((type (eql 'double-float)))
   (byte 1 63))
 
+(defmethod sign-byte-form ((type (eql 'double-float)))
+  `(byte 1 63))
+
 (defmethod nan-payload-bytespec ((type (eql 'double-float)))
   (byte 51 0))
 
+(defmethod nan-payload-byte-form ((type (eql 'double-float)))
+  `(byte 51 0))
+
 (defmethod nan-type-bytespec ((type (eql 'double-float)))
   (byte 1 51))
 
+(defmethod nan-type-byte-form ((type (eql 'double-float)))
+  `(byte 1 51))
+
 (defmethod hidden-bit-p ((type (eql 'double-float)))
   t)
 
@@ -116,22 +166,42 @@
   #+quaviver/long-float (byte 64 0)
   #-quaviver/long-float (byte 52 0))
 
+(defmethod significand-byte-form ((type (eql 'long-float)))
+  #+quaviver/long-float `(byte 64 0)
+  #-quaviver/long-float `(byte 52 0))
+
 (defmethod exponent-bytespec ((type (eql 'long-float)))
   #+quaviver/long-float (byte 15 64)
   #-quaviver/long-float (byte 11 52))
 
+(defmethod exponent-byte-form ((type (eql 'long-float)))
+  #+quaviver/long-float `(byte 15 64)
+  #-quaviver/long-float `(byte 11 52))
+
 (defmethod sign-bytespec ((type (eql 'long-float)))
   #+quaviver/long-float (byte 1 79)
   #-quaviver/long-float (byte 1 63))
 
+(defmethod sign-byte-form ((type (eql 'long-float)))
+  #+quaviver/long-float `(byte 1 79)
+  #-quaviver/long-float `(byte 1 63))
+
 (defmethod nan-payload-bytespec ((type (eql 'long-float)))
   #+quaviver/long-float (byte 63 0)
   #-quaviver/long-float (byte 51 0))
 
+(defmethod nan-payload-byte-form ((type (eql 'long-float)))
+  #+quaviver/long-float `(byte 63 0)
+  #-quaviver/long-float `(byte 51 0))
+
 (defmethod nan-type-bytespec ((type (eql 'long-float)))
   #+quaviver/long-float (byte 1 63)
   #-quaviver/long-float (byte 1 51))
 
+(defmethod nan-type-byte-form ((type (eql 'long-float)))
+  #+quaviver/long-float `(byte 1 63)
+  #-quaviver/long-float `(byte 1 51))
+
 (defmethod hidden-bit-p ((type (eql 'long-float)))
   #+quaviver/long-float nil
   #-quaviver/long-float t)