quaviver: Add integer-float for base 2

code/digits-integer.lisp

@@ -1,37 +1,43 @@
 (in-package #:quaviver)
 
 (defmethod digits-integer (client base (digits vector))
+ (declare (ignore client))
  (loop with result = 0
  for digit across digits
  finally (return result)
  do (setf result (+ (* result base) digit))))
 
 (defmethod digits-integer (client (base (eql 2)) (digits vector))
+ (declare (ignore client))
  (loop with result = 0
  for digit across digits
  finally (return result)
  do (setf result (logior (ash result 1) digit))))
 
 (defmethod digits-integer (client base (digits string))
+ (declare (ignore client))
  (loop with result = 0
  for digit across digits
  finally (return result)
  do (setf result (+ (* result base) (digit-char-p digit base)))))
 
 (defmethod digits-integer (client (base (eql 2)) (digits string))
+ (declare (ignore client))
  (loop with result = 0
  for digit across digits
  finally (return result)
  do (setf result (logior (ash result 1)
  (if (eql digit #\1) 1 0)))))
 
 (defmethod digits-integer (client base (digits list))
+ (declare (ignore client))
  (loop with result = 0
  for digit in digits
  finally (return result)
  do (setf result (+ (* result base) digit))))
 
 (defmethod digits-integer (client (base (eql 2)) (digits list))
+ (declare (ignore client))
  (loop with result = 0
  for digit in digits
  finally (return result)

code/integer-float-2.lisp

@@ -0,0 +1,120 @@
+(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)
+ (declare (ignore hidden-bit-p))
+ (multiple-value-bind (forms declarations)
+ (uiop:parse-body body)
+ `(let ((,bits-var (if (minusp sign)
+ ,(ash 1 (+ significand-size exponent-size))
+ 0)))
+ ,@declarations
+ (unless (or (>= ,exponent ,(- exponent-bias))
+ (plusp (+ ,significand-size
+ ,exponent
+ ,exponent-bias)))
+ (error "Unable to encode subnormal 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))
+ (incf ,exponent ,exponent-bias)
+ (cond ((minusp ,exponent) ; Unadjusted subnormal
+ (setf (ldb (byte (+ ,significand-size ,exponent) 0)
+ ,bits-var)
+ (ldb (byte (+ ,significand-size ,exponent) (- 1 ,exponent))
+ ,significand)))
+ (t
+ (setf (ldb (byte ,significand-size 0) ,bits-var) ,significand
+ (ldb (byte ,exponent-size ,significand-size) ,bits-var) ,exponent)))
+ ,@forms)))
+
+(declaim (inline ub32-sb32))
+(defun ub32-sb32 (ub32)
+ (if (not (zerop (ldb (byte 1 31) ub32)))
+ (- ub32 #.(ash 1 32))
+ ub32))
+
+#+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl)
+(defmethod integer-float
+ (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)
+ #+abcl
+ (system:make-single-float bits)
+ #+allegro
+ (excl:shorts-to-single-float (ldb (byte 16 16) bits)
+ (ldb (byte 16 0) bits))
+ #+ccl
+ (ccl::host-single-float-from-unsigned-byte-32 bits)
+ #+clasp
+ (ext:bits-to-single-float bits)
+ #+cmucl
+ (kernel:make-single-float (ub32-sb32 bits))
+ #+ecl
+ (system:bits-single-float bits)
+ #+lispworks
+ (let ((v (sys:make-typed-aref-vector 4)))
+ (declare (optimize (speed 3) (float 0) (safety 0))
+ (dynamic-extent v))
+ (setf (sys:typed-aref '(unsigned-byte 32) v 0) bits)
+ (sys:typed-aref 'single-float v 0))
+ #+mezzano
+ (mezzano.extensions:ieee-binary32-to-single-float bits)
+ #+sbcl
+ (sb-kernel:make-single-float (ub32-sb32 bits))))
+
+#+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl)
+(defmethod integer-float
+ (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)
+ #+abcl
+ (system:make-double-float bits)
+ #+allegro
+ (excl:shorts-to-double-float (ldb (byte 16 48) bits)
+ (ldb (byte 16 32) bits)
+ (ldb (byte 16 16) bits)
+ (ldb (byte 16 0) bits))
+ #+ccl
+ (ccl::double-float-from-bits (ldb (byte 32 32) bits)
+ (ldb (byte 32 0) bits))
+ #+clasp
+ (ext:bits-to-double-float bits)
+ #+cmucl
+ (kernel:make-double-float (ub32-sb32 (ldb (byte 32 32) bits))
+ (ldb (byte 32 0) bits))
+ #+ecl
+ (system:bits-double-float bits)
+ #+lispworks
+ (let ((upper (ldb (byte 32 32) bits))
+ (lower (ldb (byte 32 0) bits))
+ (v (sys:make-typed-aref-vector 8)))
+ (declare (optimize (speed 3) (float 0) (safety 0))
+ (dynamic-extent v))
+ #+little-endian
+ (setf (sys:typed-aref '(unsigned-byte 32) v 0) lower
+ (sys:typed-aref '(unsigned-byte 32) v 4) upper)
+ #-little-endian
+ (setf (sys:typed-aref '(unsigned-byte 32) v 0) upper
+ (sys:typed-aref '(unsigned-byte 32) v 4) lower)
+ (sys:typed-aref 'double-float v 0))
+ #+mezzano
+ (mezzano.extensions:ieee-binary64-to-double-float bits)
+ #+sbcl
+ (sb-kernel:make-double-float (ub32-sb32 (ldb (byte 32 32) bits))
+ (ldb (byte 32 0) bits))))

code/interface.lisp

@@ -4,7 +4,7 @@
 
 (defgeneric float-bits (client value))
 
-(defgeneric integer-float (client result-type base digits exponent sign))
+(defgeneric integer-float (client result-type base significand exponent sign))
 
 (defgeneric float-integer (client base value))
 

quaviver.asd

@@ -15,6 +15,7 @@
  :serial t
  :components ((:file "packages")
  (:file "interface")
+ (:file "integer-float-2")
  (:file "float-integer-2")
  (:file "digits-integer")
  (:file "integer-digits")))))