[elpa] externals/xelb 58a21fdd2f 1/6: Implement float & double types

[ELPA Syncer]

branch: externals/xelb
commit 58a21fdd2ff2051572679e10e5e6d59967237338
Author: Steven Allen <steven@stebalien.com>
Commit: Steven Allen <steven@stebalien.com>

    Implement float & double types
    
    The GLX extension needs these types but the issue was hidden by the (now
    fixed) lax type resolution rules.
    
    * xcb-types.el (xcb:-f32, xcb:-f64): Added new types for float32 and
      float64.
      (xcb:float, xcb:double): Alias these types to their C type names.
      (xcb:-f-to-binary, xcb:-binary-to-f): IEEE 754 encoder/decoder.
      (xcb:-f32-to-binary32, xcb:-binary32-to-f32): 32bit float
      encoders/decoders.
      (xcb:-f64-to-binary64, xcb:-binary64-to-f64): 64bit float
      encoders/decoders.
      (xcb:-marshal-field, xcb:-unmarshal-field): Support marshaling and
      unmarshaling to/from floats and doubles.
---
 xcb-types.el | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++
 xelb-test.el | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 176 insertions(+)

diff --git a/xcb-types.el b/xcb-types.el
index 5538838350..42e6913f6f 100644
--- a/xcb-types.el
+++ b/xcb-types.el
@@ -346,6 +346,65 @@ FORMAT-STRING is a string specifying the message to 
output, as in
         value
       (- value 4294967296.))))          ;treated as float for 32-bit
 
+(defsubst xcb:-f64-to-binary64 (value)
+  "Encode a 64-bit float VALUE as a binary64 (IEEE 754)."
+  (let* ((sigexp (frexp value))
+         (exp (+ (cdr sigexp) 1022))
+         (frac (abs (car sigexp)))
+         (isneg (< (copysign 1.0 (car sigexp)) 0)) ; use `copysign' to detect 
-0.0
+         (signmask (if isneg #x8000000000000000 0)))
+    (+ (cond ((zerop frac) 0)                                          ; 0
+             ((isnan frac) #xff0000000000001)                          ; NaN
+             ((or (>= exp 2047) (= frac 1e+INF)) #x7ff0000000000000)   ; Inf
+             ((<= exp 0) (ash (round (ldexp frac 52)) exp))            ; 
Subnormal
+             (t (+ (ash exp 52) (logand #xfffffffffffff
+                                        (round (ldexp frac 53))))))    ; Normal
+       signmask)))
+
+(defsubst xcb:-f32-to-binary32 (value)
+  "Encode a 32-bit float VALUE as a binary32 (IEEE 754)."
+  (let* ((sigexp (frexp value))
+         (exp (+ (cdr sigexp) 126))
+         (frac (abs (car sigexp)))
+         (isneg (< (copysign 1.0 (car sigexp)) 0)) ; use `copysign' to detect 
-0.0
+         (signmask (if isneg #x80000000 0)))
+    (+ (cond ((zerop frac) 0)                                                ; 0
+             ((isnan frac) #x7f800001)                                       ; 
NaN
+             ((or (>= exp 255) (= frac 1e+INF)) #x7f800000)                  ; 
Inf
+             ((<= exp 0) (ash (round (ldexp frac 23)) exp))                  ; 
Subnormal
+             (t (+ (ash exp 23) (logand #x7fffff (round (ldexp frac 24)))))) ; 
Normal
+       signmask)))
+
+(defsubst xcb:-binary64-to-f64 (value)
+  "Decode binary64 VALUE into a float."
+  (let ((sign (pcase (ash value -63)
+                (0 +0.0)
+                (1 -0.0)
+                (_ (error "[XCB] Value too large for a float64: %d" value))))
+        (exp (logand 2047 (ash value -52)))
+        (frac (logand #xfffffffffffff value)))
+    (copysign ; Use copysign, not multiplication, to deal with +/- NAN.
+     (pcase exp
+       (2047 (if (zerop frac) 1e+INF 1e+NaN))                 ; INF/NAN
+       (0    (ldexp frac -1074))                              ; Subnormal
+       (_    (ldexp (+ #x10000000000000 frac) (- exp 1075)))) ; Normal
+     sign)))
+
+(defsubst xcb:-binary32-to-f32 (value)
+  "Decode binary32 VALUE into a float."
+  (let ((sign (pcase (ash value -31)
+                (0 +0.0)
+                (1 -0.0)
+                (_ (error "[XCB] Value too large for a float32: %d" value))))
+        (exp (logand 255 (ash value -23)))
+        (frac (logand #x7fffff value)))
+    (copysign ; Use copysign, not multiplication, to deal with +/- NAN.
+     (pcase exp
+       (255 (if (zerop frac) 1e+INF 1e+NaN))        ; INF/NAN
+       (0   (ldexp frac -149))                      ; Subnormal
+       (_   (ldexp (+ #x800000 frac) (- exp 150)))) ; Normal
+     sign)))
+
 (defmacro xcb:-fieldref (field)
   "Evaluate a <fieldref> field."
   `(slot-value obj ,field))
@@ -389,6 +448,9 @@ variable property (for internal use only)."
 (cl-deftype xcb:-u4 () t)
 ;; 8 B unsigned integer
 (cl-deftype xcb:-u8 () t)
+;; floats & doubles
+(cl-deftype xcb:-f32 () t)
+(cl-deftype xcb:-f64 () t)
 ;; <pad>
 (cl-deftype xcb:-pad () t)
 ;; <pad> with align attribute
@@ -413,6 +475,8 @@ variable property (for internal use only)."
 (xcb:deftypealias 'xcb:CARD32 'xcb:-u4)
 (xcb:deftypealias 'xcb:CARD64 'xcb:-u8)
 (xcb:deftypealias 'xcb:BOOL 'xcb:-u1)
+(xcb:deftypealias 'xcb:float 'xcb:-f32)
+(xcb:deftypealias 'xcb:double 'xcb:-f64)
 
 ;;;; Struct type
 
@@ -475,6 +539,12 @@ The optional POS argument indicates current byte index of 
the field (used by
      (if (slot-value obj '~lsb) (xcb:-pack-i4-lsb value) (xcb:-pack-i4 value)))
     (`xcb:-u8
      (if (slot-value obj '~lsb) (xcb:-pack-u8-lsb value) (xcb:-pack-u8 value)))
+    (`xcb:-f32
+     (let ((value (xcb:-f32-to-binary32 value)))
+       (if (slot-value obj '~lsb) (xcb:-pack-u4-lsb value) (xcb:-pack-u4 
value))))
+    (`xcb:-f64
+     (let ((value (xcb:-f64-to-binary64 value)))
+       (if (slot-value obj '~lsb) (xcb:-pack-u8-lsb value) (xcb:-pack-u8 
value))))
     (`xcb:void (vector value))
     (`xcb:-pad
      (unless (integerp value)
@@ -604,6 +674,16 @@ and the second the consumed length."
                         (xcb:-unpack-u8-lsb data offset)
                       (xcb:-unpack-u8 data offset))
                     8))
+    (`xcb:-f32 (list (xcb:-binary32-to-f32
+                      (if (slot-value obj '~lsb)
+                          (xcb:-unpack-u4-lsb data offset)
+                        (xcb:-unpack-u4 data offset)))
+                      4))
+    (`xcb:-f64 (list (xcb:-binary64-to-f64
+                      (if (slot-value obj '~lsb)
+                          (xcb:-unpack-u8-lsb data offset)
+                        (xcb:-unpack-u8 data offset)))
+                      8))
     (`xcb:void (list (aref data offset) 1))
     (`xcb:-pad
      (unless (integerp initform)
diff --git a/xelb-test.el b/xelb-test.el
new file mode 100644
index 0000000000..ed7e6f8776
--- /dev/null
+++ b/xelb-test.el
@@ -0,0 +1,96 @@
+;;; xelb-test.el --- Unit tests for XELB -*- lexical-binding: t -*-
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; Author: Steven Allen <steven@stebalien.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module contains unit tests for testing XELB.
+
+;;; Code:
+
+(require 'ert)
+(require 'xcb-types)
+
+;; 
https://en.wikipedia.org/wiki/Single-precision_floating-point_format#Notable_single-precision_cases
+(defconst xelb-test-binary32-cases
+  '((#x00000001 . 1.401298464324817e-45)
+    (#x007fffff . 1.1754942106924411e-38)
+    (#x00800000 . 1.1754943508222875e-38)
+    (#x7f7fffff . 3.4028234663852886e38)
+    (#x3f7fffff . 0.999999940395355225)
+    (#x3f800000 . 1.0)
+    (#x3f800001 . 1.00000011920928955)
+    (#xc0000000 . -2.0)
+    (#x00000000 . 0.0)
+    (#x80000000 . -0.0)
+    (#x7f800000 . 1e+INF)
+    (#xff800000 . -1e+INF)
+    (#x40490fdb . 3.14159274101257324)
+    (#x3eaaaaab . 0.333333343267440796)))
+
+;; 
https://en.wikipedia.org/wiki/Double-precision_floating-point_format#Double-precision_examples
+(defconst xelb-test-binary64-cases
+  `((#x3ff0000000000000 . 1.0)
+    (#x3ff0000000000001 . 1.0000000000000002)
+    (#x3ff0000000000002 . 1.0000000000000004)
+    (#x4000000000000000 . 2.0)
+    (#xc000000000000000 . -2.0)
+    (#x4008000000000000 . 3.0)
+    (#x4010000000000000 . 4.0)
+    (#x4014000000000000 . 5.0)
+    (#x4018000000000000 . 6.0)
+    (#x4037000000000000 . 23.0)
+    (#x3f88000000000000 . 0.01171875)
+    (#x0000000000000001 . 4.9406564584124654e-324)
+    (#x000fffffffffffff . 2.2250738585072009e-308)
+    (#x0010000000000000 . 2.2250738585072014e-308)
+    (#x7fefffffffffffff . 1.7976931348623157e308)
+    (#x0000000000000000 . +0.0)
+    (#x8000000000000000 . -0.0)
+    (#x7ff0000000000000 . +1e+INF)
+    (#xfff0000000000000 . -1e+INF)
+    (#x3fd5555555555555 . ,(/ 1.0 3.0))
+    (#x400921fb54442d18 . ,float-pi)))
+
+(defun xelb-test--test-conversion (a-to-b b-to-a cases)
+  "Test the bidirectional conversion functions A-TO-B and B-TO-A against CASES.
+CASES is an alist of (A . B) pairs."
+  (pcase-dolist (`(,a . ,b) cases)
+    (let* ((act-a (funcall b-to-a b))
+           (act-b (funcall a-to-b a))
+           (round-trip-a (funcall b-to-a act-b))
+           (round-trip-b (funcall a-to-b act-a)))
+      (should (= b act-b round-trip-b))
+      (should (= a act-a round-trip-a)))))
+
+(ert-deftest xelb-test-binary32 ()
+  (xelb-test--test-conversion
+   #'xcb:-binary32-to-f32
+   #'xcb:-f32-to-binary32
+   xelb-test-binary32-cases))
+
+(ert-deftest xelb-test-binary64 ()
+  (xelb-test--test-conversion
+   #'xcb:-binary64-to-f64
+   #'xcb:-f64-to-binary64
+   xelb-test-binary64-cases))
+
+(provide 'xelb-test)
+
+;;; xelb-test.el ends here