#||
(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)
(define-modify-macro idecf (&optional (delta 1)) i-)
) ;#-quux
+
+\f
+;;; 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)))))
(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)))
(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)
(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.
(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.
(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)) ()
(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)))))
(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.
(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.
projects / cl-protobufs.git / commitdiff