quaviver, schubfach, liebler: Add float trait generic functions

code/float-integer-2.lisp

@@ -1,46 +1,51 @@
 (in-package #:quaviver)
 
-(defmacro %integer-decode-float
- (value
- &key significand-size
- exponent-size
- ((:hidden-bit hidden-bit-p) nil)
- exponent-bias)
- `(let* ((bits ,value)
- (significand (ldb (byte ,significand-size 0) bits))
- (exponent (ldb (byte ,exponent-size ,significand-size) bits))
- (sign (if (logbitp ,(+ exponent-size significand-size) bits) -1 1)))
- (declare (type (unsigned-byte ,(+ 1 exponent-size significand-size))
- bits)
- (type (unsigned-byte ,significand-size)
- significand)
- (type (unsigned-byte ,exponent-size)
- exponent)
- (type (integer -1 1)
- sign))
- (cond ((= exponent ,(1- (ash 1 exponent-size)))
- (if (zerop significand) ; infinity
- (values 0 :infinity sign)
- (values (ldb (byte ,(1- significand-size) 0) significand)
- (if (logbitp ,(1- significand-size) significand)
- :quiet-nan
- :signaling-nan)
- sign)))
- ((and (zerop significand)
- (zerop exponent))
- (values 0 0 sign))
- ((zerop exponent) ; subnormal
- (let ((shift (- ,(if hidden-bit-p (1+ significand-size) significand-size)
- (integer-length significand))))
- (values (ash significand shift)
- (- ,(- 1 exponent-bias) shift)
- sign)))
- (t
- (values ,(if hidden-bit-p
- `(logior significand ,(ash 1 significand-size))
- 'significand)
- (- exponent ,exponent-bias)
- sign)))))
+(defmacro %integer-decode-float (type value)
+ (with-accessors ((storage-size storage-size)
+ (significand-bytespec significand-bytespec)
+ (exponent-bytespec exponent-bytespec)
+ (sign-bytespec sign-bytespec)
+ (nan-payload-bytespec nan-payload-bytespec)
+ (nan-type-bytespec nan-type-bytespec)
+ (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)))
+ (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)
+ :quiet-nan
+ :signaling-nan)
+ 1)
+ (values 0 :infinity sign)))
+ (t
+ (let ((significand (ldb ',significand-bytespec bits)))
+ (declare (type (unsigned-byte ,(byte-size significand-bytespec))
+ significand))
+ (cond ((and (zerop significand)
+ (zerop exponent))
+ (values 0 0 sign))
+ ((zerop exponent) ; subnormal
+ (let ((shift (- ,(byte-size significand-bytespec)
+ (integer-length significand))))
+ (values (ash significand shift)
+ (- ,(- 1 exponent-bias) shift)
+ sign)))
+ (t
+ (values ,(if hidden-bit-p
+ `(logior significand ,(ash 1 (byte-size significand-bytespec)))
+ 'significand)
+ (- exponent ,exponent-bias)
+ sign)))))))))
 
 #-(or abcl allegro clasp cmucl ecl lispworks sbcl)
 (defmethod float-integer (client (base (eql 2)) value)
@@ -53,6 +58,7 @@
 (defmethod float-integer (client (base (eql 2)) (value single-float))
  (declare (ignore client))
  (%integer-decode-float
+ single-float
  #+abcl (system:single-float-bits value)
  #+allegro (multiple-value-bind (us1 us0)
  (excl:single-float-to-shorts value)
@@ -67,16 +73,13 @@
  (setf (sys:typed-aref 'single-float v 0) value)
  (sys:typed-aref '(unsigned-byte 32) v 0))
  #+sbcl (ldb (byte 32 0)
- (sb-kernel:single-float-bits value))
- :significand-size 23
- :exponent-size 8
- :hidden-bit t
- :exponent-bias 150))
+ (sb-kernel:single-float-bits value))))
 
 #+(or abcl allegro clasp cmucl ecl lispworks sbcl)
 (defmethod float-integer (client (base (eql 2)) (value double-float))
  (declare (ignore client))
  (%integer-decode-float
+ double-float
  #+abcl (logior (ash (system:double-float-high-bits value) 32)
  (system:double-float-low-bits value))
  #+allegro (multiple-value-bind (us3 us2 us1 us0)
@@ -103,18 +106,10 @@
  #+sbcl (logior (ash (ldb (byte 32 0)
  (sb-kernel:double-float-high-bits value))
  32)
- (sb-kernel:double-float-low-bits value))
- :significand-size 52
- :exponent-size 11
- :hidden-bit t
- :exponent-bias 1075))
+ (sb-kernel:double-float-low-bits value))))
 
 #+quaviver/long-float
 (defmethod float-integer (client (base (eql 2)) (value long-float))
  (declare (ignore client))
- (%integer-decode-float
- (system:long-float-bits value)
- :significand-size 64
- :exponent-size 15
- :hidden-bit nil
- :exponent-bias 16446))
+ (%integer-decode-float long-float
+ (system:long-float-bits value)))

code/integer-float-2.lisp

@@ -1,67 +1,73 @@
 (in-package #:quaviver)
 
 (defmacro %integer-encode-float
- ((bits-var significand exponent sign
- &key significand-size
- exponent-size
- ((:hidden-bit hidden-bit-p) nil)
- exponent-bias)
- &body body)
- (let ((decoded-significand-size (if hidden-bit-p
- (1+ significand-size)
- significand-size)))
+ ((type bits-var significand exponent sign) &body body)
+ (with-accessors ((storage-size storage-size)
+ (significand-bytespec significand-bytespec)
+ (exponent-bytespec exponent-bytespec)
+ (sign-bytespec sign-bytespec)
+ (nan-payload-bytespec nan-payload-bytespec)
+ (nan-type-bytespec nan-type-bytespec)
+ (hidden-bit-p hidden-bit-p)
+ (exponent-bias exponent-bias))
+ type
  (multiple-value-bind (forms declarations)
  (alexandria:parse-body body)
- `(let ((,bits-var (if (minusp ,sign)
- ,(ash 1 (+ significand-size exponent-size))
- 0)))
+ `(let ((,bits-var 0))
  ,@declarations
+ (declare (type (unsigned-byte ,storage-size) ,bits-var))
+ (when (minusp ,sign)
+ (setf (ldb ',sign-bytespec ,bits-var) 1))
  (cond ((keywordp exponent)
- (setf (ldb (byte ,exponent-size ,significand-size) ,bits-var)
- ,(1- (ash 1 exponent-size)))
+ (setf (ldb ',exponent-bytespec ,bits-var)
+ ,(1- (ash 1 (byte-size exponent-bytespec))))
  (ecase exponent
  (:infinity)
  (:quiet-nan
- (setf (ldb (byte 1 ,(1- significand-size)) ,bits-var)
- 1
- (ldb (byte ,(1- significand-size) 0) ,bits-var)
- ,significand))
+ (setf (ldb ',nan-type-bytespec ,bits-var) 1
+ (ldb ',nan-payload-bytespec ,bits-var) ,significand))
  (:signaling-nan
- (setf (ldb (byte ,(1- significand-size) 0) ,bits-var)
+ (setf (ldb ',nan-payload-bytespec ,bits-var)
  (if (zerop ,significand) 1 ,significand)))))
  (t
  (unless (zerop ,significand)
- (let ((shift (- ,decoded-significand-size
+ (let ((shift (- ,(if hidden-bit-p
+ (1+ (byte-size significand-bytespec))
+ (byte-size significand-bytespec))
  (integer-length ,significand))))
  (setf ,significand (ash ,significand shift))
  (decf ,exponent shift)))
  (cond ((zerop ,significand)
- (setf (ldb (byte ,exponent-size ,significand-size) ,bits-var)
- ,exponent-bias))
+ (setf (ldb ',exponent-bytespec ,bits-var) ,exponent-bias))
  (t
  (unless (and (< ,exponent
- ,(- (1- (ash 1 exponent-size)) exponent-bias))
+ ,(- (1- (ash 1 (byte-size exponent-bytespec)))
+ exponent-bias))
  (or (>= ,exponent ,(- exponent-bias))
- (plusp (+ ,significand-size
+ (plusp (+ ,(byte-size significand-bytespec)
  ,exponent
  ,exponent-bias))))
  (error "Unable to encode float with significand of ~a and ~
  exponent of ~a when~%the significand size is ~a and ~
  the exponent size is ~a."
  ,significand ,exponent
- ,significand-size ,exponent-size))
+ ,(byte-size significand-bytespec)
+ ,(byte-size exponent-bytespec)))
  (incf ,exponent ,exponent-bias)
  (cond ((plusp ,exponent)
- (setf (ldb (byte ,significand-size 0) ,bits-var)
+ (setf (ldb ',significand-bytespec ,bits-var)
  ,significand
- (ldb (byte ,exponent-size ,significand-size) ,bits-var)
+ (ldb ',exponent-bytespec ,bits-var)
  ,exponent))
  (t ; Unadjusted subnormal
- (setf (ldb (byte (+ ,significand-size ,exponent)
- 0)
+ (setf (ldb (byte (+ ,(byte-size significand-bytespec)
+ ,exponent)
+ ,(byte-position significand-bytespec))
  ,bits-var)
- (ldb (byte (+ ,significand-size ,exponent)
- (- 1 ,exponent))
+ (ldb (byte (+ ,(byte-size significand-bytespec)
+ ,exponent)
+ (- ,(1+ (byte-position significand-bytespec))
+ ,exponent))
  ,significand))))))))
  ,@forms))))
 
@@ -76,11 +82,7 @@
  (client (result-type (eql 'single-float)) (base (eql 2)) significand exponent sign)
  (declare (ignore client))
  (%integer-encode-float
- (bits significand exponent sign
- :significand-size 23
- :exponent-size 8
- :hidden-bit t
- :exponent-bias 150)
+ (single-float bits significand exponent sign)
  #+abcl
  (system:make-single-float bits)
  #+allegro
@@ -110,11 +112,7 @@
  (client (result-type (eql 'double-float)) (base (eql 2)) significand exponent sign)
  (declare (ignore client))
  (%integer-encode-float
- (bits significand exponent sign
- :significand-size 52
- :exponent-size 11
- :hidden-bit t
- :exponent-bias 1075)
+ (double-float bits significand exponent sign)
  #+abcl
  (system:make-double-float bits)
  #+allegro

code/interface.lisp

@@ -11,3 +11,31 @@
 (defgeneric digits-integer (client base digits))
 
 (defgeneric integer-digits (client result-type base value))
+
+(defgeneric storage-size (type))
+
+(defgeneric significand-bytespec (type))
+
+(defgeneric exponent-bytespec (type))
+
+(defgeneric sign-bytespec (type))
+
+(defgeneric nan-payload-bytespec (type))
+
+(defgeneric nan-type-bytespec (type))
+
+(defgeneric hidden-bit-p (type))
+
+(defgeneric exponent-bias (type))
+
+(defgeneric max-exponent (type))
+
+(defgeneric min-exponent (type))
+
+(defgeneric significand-size (type)
+ (:method (type)
+ (if (hidden-bit-p type)
+ (1+ (byte-size (significand-bytespec type)))
+ (byte-size (significand-bytespec type)))))
+
+(defgeneric arithmetic-size (type))

code/liebler/implementation.lisp

@@ -3,43 +3,43 @@
 (defclass client ()
  ())
 
-(defmacro %liebler (client result-type significand exponent sign bits significand-size expt10 round-to-odd)
- `(if (or (not (numberp ,exponent))
- (zerop ,significand))
- (quaviver:integer-float ,client ,result-type 2
- ,significand ,exponent ,sign)
- (let ((k (quaviver/math:floor-log2-expt10 ,exponent))
- (shift (- ,bits (integer-length ,significand))))
- (setf ,significand (,round-to-odd (,expt10 (- ,exponent))
- (ash ,significand shift))
- k (- k -1 shift)
- shift (- ,significand-size (integer-length ,significand)))
- (quaviver:integer-float ,client ,result-type 2
- (round ,significand (ash 1 (- shift)))
- (- k shift)
- ,sign))))
+(defmacro %liebler (client result-type significand exponent sign expt10 round-to-odd)
+ (with-accessors ((arithmetic-size quaviver:arithmetic-size)
+ (significand-size quaviver:significand-size))
+ result-type
+ `(if (or (not (numberp ,exponent))
+ (zerop ,significand))
+ (quaviver:integer-float ,client ',result-type 2
+ ,significand ,exponent ,sign)
+ (let ((k (quaviver/math:floor-log2-expt10 ,exponent))
+ (shift (- ,arithmetic-size (integer-length ,significand))))
+ (setf ,significand (,round-to-odd (,expt10 (- ,exponent))
+ (ash ,significand shift))
+ k (- k -1 shift)
+ shift (- ,significand-size (integer-length ,significand)))
+ (quaviver:integer-float ,client ',result-type 2
+ (round ,significand (ash 1 (- shift)))
+ (- k shift)
+ ,sign)))))
 
 (defmethod quaviver:integer-float
  ((client client) (result-type (eql 'single-float)) (base (eql 10)) significand exponent sign)
- (%liebler client result-type
+ (%liebler client single-float
  significand exponent sign
- 32 24
  quaviver/math:expt10/32
  quaviver/math:round-to-odd/32))
 
 (defmethod quaviver:integer-float
  ((client client) (result-type (eql 'double-float)) (base (eql 10)) significand exponent sign)
- (%liebler client result-type
+ (%liebler client double-float
  significand exponent sign
- 64 53
  quaviver/math:expt10/64
  quaviver/math:round-to-odd/64))
 
 #+quaviver/long-float
 (defmethod quaviver:integer-float
  ((client client) (result-type (eql 'long-float)) (base (eql 10)) significand exponent sign)
- (%liebler client result-type
+ (%liebler client long-float
  significand exponent sign
- 128 64
  quaviver/math:expt10/128
  quaviver/math:round-to-odd/128))

code/packages.lisp

@@ -5,7 +5,19 @@
  #:integer-float
  #:float-integer
  #:digits-integer
- #:integer-digits))
+ #:integer-digits
+ #:storage-size
+ #:significand-bytespec
+ #:exponent-bytespec
+ #:sign-bytespec
+ #:nan-payload-bytespec
+ #:nan-type-bytespec
+ #:hidden-bit-p
+ #:exponent-bias
+ #:max-exponent
+ #:min-exponent
+ #:significand-size
+ #:arithmetic-size))
 
 #+(and ecl long-float)
 (eval-when (:compile-toplevel :load-toplevel :execute)