From: Scott McKay <swm@google.com>
Date: Wed, 14 Mar 2012 15:29:17 +0000 (+0000)
Subject: Support floating point in the wire protocol
X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=commitdiff_plain;h=75d6860f741b222179d5b71292fc1ced3bb7872b;p=cl-protobufs.git

Support floating point in the wire protocol

git-svn-id: http://svn.internal.itasoftware.com/svn/ita/branches/qres/swm/borgify-1/qres/lisp/quux/protobufs@533978 f8382938-511b-0410-9cdd-bb47b084005c
---

diff --git a/examples.lisp b/examples.lisp
index 0104167..73c4e57 100644
--- a/examples.lisp
+++ b/examples.lisp
@@ -338,31 +338,37 @@ service ColorWheel {
 
 #||
 (proto:define-proto read-air-reservation (:package qres-core)
-  (proto:define-message air-reservation-spec ()
-    (locator :type (list-of pnr-locator))
-    (customer :type (or null string))
-    (contract-group-id :type (or null integer))
-    (last-name :type (or null string))
-    (first-name :type (or null string))
-    (phone-number :type (or null string))
-    (email-address :type (or null string))
-    (cc-number :type (or null string))
-    (ticket-number :type (or null string))
-    (ff-account :type (or null ff-account))
-    (flights :type (list-of flight-spec)))
-  (proto:define-message pnr-locator ()
-    (system :type string)
-    (locator :type string))
-  (proto:define-message ff-account ()
-    (carrier :type string)
-    (number :type string))
-  (proto:define-message flight-spec ()
-    (carrier :type string)
-    (flight-number :type integer)
-    (suffix :type (or null string))
-    (date :type string)
-    (origin :type (or null string))
-    (destination :type (or null string))))
+  (proto:define-message read-air-reservation-request ()
+    (proto:define-message air-reservation-spec ()
+      (locator :type (list-of pnr-locator))
+      (customer :type (or null string))
+      (contract-group-id :type (or null integer))
+      (last-name :type (or null string))
+      (first-name :type (or null string))
+      (phone-number :type (or null string))
+      (email-address :type (or null string))
+      (cc-number :type (or null string))
+      (ticket-number :type (or null string))
+      (ff-account :type (or null ff-account))
+      (flights :type (list-of flight-spec)))
+    (proto:define-message pnr-locator ()
+      (system :type string)
+      (locator :type string))
+    (proto:define-message ff-account ()
+      (carrier :type string)
+      (number :type string))
+    (proto:define-message flight-spec ()
+      (carrier :type string)
+      (flight-number :type integer)
+      (suffix :type (or null string))
+      (date :type string)
+      (origin :type (or null string))
+      (destination :type (or null string)))
+    (spec :type air-reservation-spec))
+  (proto:define-message read-air-reservation-response ()
+    )
+  (proto:define-service read-air-reservation ()
+    (read-air-reservation read-air-reservation-request read-air-reservation-response)))
 
 (proto:write-protobuf *read-air-reservation*)
 (proto:write-protobuf *read-air-reservation* :type :lisp)
diff --git a/utilities.lisp b/utilities.lisp
index a655231..66d95e7 100644
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -88,3 +88,195 @@
 (define-modify-macro idecf (&optional (delta 1)) i-)
 
 )       ;#-quux
+
+
+;;; Floating point utilities
+
+#+(or abcl allegro cmu sbcl lispworks)
+(defun single-float-bits (x)
+  (declare (type single-float x))
+  #+abcl    (system:single-float-bits float)
+  #+allegro (multiple-value-bind (high low)
+                (excl:single-float-to-shorts float)
+              (declare (type (unsigned-byte 16) high low))
+              (logior (ash high 16) low))
+  #+cmu  (kernel:single-float-bits float)
+  #+sbcl (sb-kernel:single-float-bits float)
+  #+lispworks (lispworks-float:single-float-bits float))
+
+#-(or abcl allegro cmu sbcl lispworks)
+(defun single-float-bits (x)
+  (declare (type single-float x))
+  (assert (= (float-radix x) 2))
+  (if (zerop x)
+    (if (eql x 0.0f0) 0 #x-80000000)
+    (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
+        (integer-decode-float x)
+      (assert (plusp lisp-significand))
+      (let* ((significand lisp-significand)
+             (exponent (+ lisp-exponent 23 127))
+             (unsigned-result
+              (if (plusp exponent)                      ;if not obviously denormalized
+                (do () (nil)
+                  (cond
+                    ;; Special termination case for denormalized float number
+                    ((zerop exponent)
+                     ;; Denormalized numbers have exponent one greater than
+                     ;; in the exponent field
+                     (return (ash significand -1)))
+                    ;; Ordinary termination case
+                    ((>= significand (expt 2 23))
+                     (assert (< 0 significand (expt 2 24)))
+                     ;; Exponent 0 is reserved for denormalized numbers,
+                     ;; and 255 is reserved for specials like NaN
+                     (assert (< 0 exponent 255))
+                     (return (logior (ash exponent 23)
+                                     (logand significand (1- (ash 1 23))))))
+                    (t
+                     ;; Shift as necessary to set bit 24 of significand
+                     (setq significand (ash significand 1)
+                           exponent (1- exponent)))))
+                (do () ((zerop exponent)
+                        ;; Denormalized numbers have exponent one greater than
+                        ;; the exponent field
+                        (ash significand -1))
+                  (unless (zerop (logand significand 1))
+                    (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
+                  (setq significand (ash significand -1)
+                        exponent (1+ exponent))))))
+        (ecase lisp-sign
+          ((1)  unsigned-result)
+          ((-1) (logior unsigned-result (- (expt 2 31)))))))))
+
+
+#+(or abcl allegro cmu sbcl lispworks)
+(defun double-float-bits (x)
+  (declare (type double-float x))
+  #+abcl    (values (system:double-float-low-bits float)
+                    (system:double-float-high-bits float))
+  #+allegro (multiple-value-bind (us3 us2 us1 us0)
+                (excl:double-float-to-shorts float)
+              (logior (ash us1 16) us0)
+              (logior (ash us3 16) us2))
+  #+cmu  (values (kernel:double-float-low-bits float)
+                 (kernel:double-float-high-bits float))
+  #+sbcl (values (sb-kernel:double-float-low-bits float)
+                 (sb-kernel:double-float-high-bits float))
+  #+lispworks (let ((bits (lispworks-float:double-float-bits float)))
+                (values (logand #xffffffff bits)
+                        (ash bits -32))))
+
+#-(or abcl allegro cmu sbcl lispworks)
+(defun double-float-bits (x)
+  (declare (type double-float x))
+  (assert (= (float-radix x) 2))
+  (if (zerop x)
+    (if (eql x 0.0d0) 0 #x-8000000000000000)
+    (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
+        (integer-decode-float x)
+      (assert (plusp lisp-significand))
+      (let* ((significand lisp-significand)
+             (exponent (+ lisp-exponent 52 1023))
+             (unsigned-result
+              (if (plusp exponent)                      ;if not obviously denormalized
+                (do () (nil)
+                  (cond
+                    ;; Special termination case for denormalized float number
+                    ((zerop exponent)
+                     ;; Denormalized numbers have exponent one greater than
+                     ;; in the exponent field
+                     (return (ash significand -1)))
+                    ;; Ordinary termination case
+                    ((>= significand (expt 2 52))
+                     (assert (< 0 significand (expt 2 53)))
+                     ;; Exponent 0 is reserved for denormalized numbers,
+                     ;; and 2047 is reserved for specials like NaN
+                     (assert (< 0 exponent 2047))
+                     (return (logior (ash exponent 52)
+                                     (logand significand (1- (ash 1 52))))))
+                    (t
+                     ;; Shift as necessary to set bit 53 of significand
+                     (setq significand (ash significand 1)
+                           exponent (1- exponent)))))
+                (do () ((zerop exponent)
+                        ;; Denormalized numbers have exponent one greater than
+                        ;; the exponent field
+                        (ash significand -1))
+                  (unless (zerop (logand significand 1))
+                    (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
+                  (setq significand (ash significand -1)
+                        exponent (1+ exponent))))))
+        (let ((result
+               (ecase lisp-sign
+                 ((1)  unsigned-result)
+                 ((-1) (logior unsigned-result (- (expt 2 63)))))))
+          ;; Return the low bits and the high bits
+          (values (logand #xffffffff result) (ash result -32)))))))
+
+
+#+(or abcl allegro cmu sbcl lispworks)
+(defun make-single-float (bits)
+  (declare (type (signed-byte 32) bits))
+  #+abcl    (system:make-single-float bits)
+  #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
+                                         (ldb (byte 16 0) bits))
+  #+cmu  (kernel:make-single-float bits)
+  #+sbcl (sb-kernel:make-single-float bits)
+  #+lispworks (lispworks-float:make-single-float bits))
+
+#-(or abcl allegro cmu sbcl lispworks)
+(defun make-single-float (bits)
+  (declare (type (signed-byte 32) bits))
+  (cond
+    ;; IEEE float special cases
+    ((zerop bits) 0.0)
+    ((= bits #x-80000000) -0.0)                         ;--- change if unsigned-byte argument
+    (t
+     (let* ((sign (ecase (ldb (byte 1 31) bits)
+                    (0 1.0)
+                    (1 -1.0)))
+            (iexpt (ldb (byte 8 23) bits))
+            (exponent (if (zerop iexpt)                 ;denormalized
+                        -126
+                        (- iexpt 127)))
+            (mantissa (* (logior (ldb (byte 23 0) bits)
+                                 (if (zerop iexpt) 0 (ash 1 23)))
+                         (expt 0.5 23))))
+       (* sign (expt 2.0 exponent) mantissa)))))
+
+
+#+(or abcl allegro cmu sbcl lispworks)
+(defun make-double-float (low-bits high-bits)
+  (declare (type (unsigned-byte 32) low-bits)
+           (type (signed-byte   32) high-bits))
+  #+abcl (system:make-double-float (logior (ash high 32) low))
+  #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
+                                         (ldb (byte 16 0) high)
+                                         (ldb (byte 16 16) low)
+                                         (ldb (byte 16 0) low))
+  #+cmu  (kernel:make-double-float high low)
+  #+sbcl (sb-kernel:make-double-float high low)
+  #+lispworks (lispworks-float:make-double-float high low))
+
+#-(or abcl allegro cmu sbcl lispworks)
+(defun make-double-float (low-bits high-bits)
+  (declare (type (unsigned-byte 32) low-bits)
+           (type (signed-byte   32) high-bits))
+  (cond
+    ;; IEEE float special cases
+    ((and (zerop high-bits) (zerop low-bits)) 0.0d0)
+    ((and (= high-bits #x-80000000)                     ;--- change if unsigned-byte arguments
+          (zerop low-bits)) -0.0d0)
+    (t
+     (let* ((bits (logior (ash high-bits 32) low-bits))
+            (sign (ecase (ldb (byte 1 63) bits)
+                    (0 1.0d0)
+                    (1 -1.0d0)))
+            (iexpt (ldb (byte 11 52) bits))
+            (exponent (if (zerop iexpt)                 ;denormalized
+                        -1022
+                        (- iexpt 1023)))
+            (mantissa (* (logior (ldb (byte 52 0) bits)
+                                 (if (zerop iexpt) 0 (ash 1 52)))
+                         (expt 0.5d0 52))))
+       (* sign (expt 2.0d0 exponent) mantissa)))))
diff --git a/wire-format.lisp b/wire-format.lisp
index 0573eb1..9881170 100644
--- a/wire-format.lisp
+++ b/wire-format.lisp
@@ -49,11 +49,13 @@
        (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
               (idx (encode-uint32 tag buffer index)))
          (declare (type fixnum tag idx))
+         ;;--- Shouldn't this always be writing 4 bytes?
          (encode-uint32 val buffer idx)))
       ((:fixed64 :sfixed64)
        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
               (idx (encode-uint32 tag buffer index)))
          (declare (type fixnum tag idx))
+         ;;--- Shouldn't this always be writing 8 bytes?
          (encode-uint64 val buffer idx)))
       ((:string)
        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
@@ -185,8 +187,10 @@
            (decode-uint64 buffer index)
          (values (zig-zag-decode64 val) idx)))
       ((:fixed32 :sfixed32)
+       ;;--- Shouldn't this always be reading 4 bytes?
        (decode-uint32 buffer index))
       ((:fixed64 :sfixed64)
+       ;;--- Shouldn't this always be reading 8 bytes?
        (decode-uint64 buffer index))
       ((:string)
        (multiple-value-bind (val idx)
@@ -388,8 +392,14 @@
   (declare (type fixnum index)
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
-    ;;---*** Do encoding of single floats
-    val buffer index))
+    (let ((bits (single-float-bits val)))
+      (loop repeat 4 doing
+        (let ((byte (ldb #.(byte 8 0) bits)))
+          (declare (type fixnum byte))
+          (setq bits (ash bits -8))
+          (setf (aref buffer index) byte)
+          (iincf index)))))
+  (values index buffer))
 
 (defun encode-double (val buffer index)
   "Encodes the double float 'val' into the buffer at the given index.
@@ -397,8 +407,21 @@
   (declare (type fixnum index)
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
-    ;;---*** Do encoding of double floats
-    val buffer index))
+    (multiple-value-bind (low high)
+        (double-float-bits val)
+      (loop repeat 4 doing
+        (let ((byte (ldb #.(byte 8 0) low)))
+          (declare (type fixnum byte))
+          (setq low (ash low -8))
+          (setf (aref buffer index) byte)
+          (iincf index)))
+      (loop repeat 4 doing
+        (let ((byte (ldb #.(byte 8 0) high)))
+          (declare (type fixnum byte))
+          (setq high (ash high -8))
+          (setf (aref buffer index) byte)
+          (iincf index)))))
+  (values index buffer))
 
 (defun encode-octets (octets buffer index)
   "Encodes the octets into the buffer at the given index.
@@ -434,10 +457,10 @@
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
     ;; Seven bits at a time, least significant bits first
-    (loop with val fixnum = 0
+    (loop with val = 0
           for places fixnum upfrom 0 by 7
           for byte fixnum = (prog1 (aref buffer index) (iincf index))
-          do (setq val (ilogior val (ash (ldb #.(byte 7 0) byte) places)))
+          do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
           until (i< byte 128)
           finally (progn
                     (assert (< val #.(ash 1 32)) ()
@@ -451,10 +474,10 @@
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
     ;; Seven bits at a time, least significant bits first
-    (loop with val fixnum = 0
+    (loop with val = 0
           for places fixnum upfrom 0 by 7
           for byte fixnum = (prog1 (aref buffer index) (iincf index))
-          do (setq val (ilogior val (ash (ldb #.(byte 7 0) byte) places)))
+          do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
           until (i< byte 128)
           finally (return (values val index)))))
 
@@ -464,8 +487,15 @@
   (declare (type fixnum index)
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
-    ;;---*** Do decoding of single floats
-    buffer index))
+    ;; Eight bits at a time, least significant bits first
+    (let ((bits 0))
+      (loop repeat 4
+            for places fixnum upfrom 0 by 8
+            for byte fixnum = (prog1 (aref buffer index) (iincf index))
+            do (setq bits (logior bits (ash byte places))))
+      (when (i= (ldb #.(byte 1 31) bits) 1)             ;sign bit set, so negative value
+        (decf bits #.(ash 1 32)))
+      (values (make-single-float bits) index))))
 
 (defun decode-double (buffer index)
   "Decodes the next double float in the buffer at the given index.
@@ -473,8 +503,21 @@
   (declare (type fixnum index)
            (type (simple-array (unsigned-byte 8)) buffer))
   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
-    ;;---*** Do decoding of double floats
-    buffer index))
+    ;; Eight bits at a time, least significant bits first
+    (let ((low  0)
+          (high 0))
+      (loop repeat 4
+            for places fixnum upfrom 0 by 8
+            for byte fixnum = (prog1 (aref buffer index) (iincf index))
+            do (setq low (logior low (ash byte places))))
+      (loop repeat 4
+            for places fixnum upfrom 0 by 8
+            for byte fixnum = (prog1 (aref buffer index) (iincf index))
+            do (setq high (logior high (ash byte places))))
+      ;; High bits are signed, but low bits are unsigned
+      (when (i= (ldb #.(byte 1 31) high) 1)             ;sign bit set, so negative value
+        (decf high #.(ash 1 32)))
+      (values (make-double-float low high) index))))
 
 (defun decode-octets (buffer index)
   "Decodes the next octets in the buffer at the given index.