From bdaeb13fa5b10a63381aff242d32db92d6499f84 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sun, 16 Jun 2024 10:32:47 -0400 Subject: [PATCH] quaviver: Add integer-float for base 2 --- code/digits-integer.lisp | 6 ++ code/integer-float-2.lisp | 120 ++++++++++++++++++++++++++++++++++++++ code/interface.lisp | 2 +- quaviver.asd | 1 + 4 files changed, 128 insertions(+), 1 deletion(-) create mode 100644 code/integer-float-2.lisp diff --git a/code/digits-integer.lisp b/code/digits-integer.lisp index d81f3887..36da4d22 100644 --- a/code/digits-integer.lisp +++ b/code/digits-integer.lisp @@ -1,24 +1,28 @@ (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) @@ -26,12 +30,14 @@ (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) diff --git a/code/integer-float-2.lisp b/code/integer-float-2.lisp new file mode 100644 index 00000000..8d327bb6 --- /dev/null +++ b/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)))) diff --git a/code/interface.lisp b/code/interface.lisp index 10f935f2..bb8878e2 100644 --- a/code/interface.lisp +++ b/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)) diff --git a/quaviver.asd b/quaviver.asd index a98551e7..f5a98e5b 100644 --- a/quaviver.asd +++ b/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")))))