Permalink
Browse files

Add Lispworks floating point support using an FLI technique by

Joel Reymont.
Fix errors with single floating point literals -- use 123f0 not 123s0.
  • Loading branch information...
brown committed Sep 30, 2011
1 parent a71dcc8 commit add374a48289bc6d877debd5e4af50aa0ae909e2
Showing with 225 additions and 146 deletions.
  1. +2 −3 TODO
  2. +74 −0 lispworks-float.lisp
  3. +15 −15 message-test.lisp
  4. +43 −38 package.lisp
  5. +5 −8 portable-float.lisp
  6. +36 −38 protobuf.asd
  7. +2 −2 protoc/lisp/helpers.cc
  8. +48 −42 wire-format.lisp
View
5 TODO
@@ -11,17 +11,16 @@ structure.
Remove all references to the BASE package in generated code. Make generated
files independently loadable.
+Use base::vector-index or eliminate it in protobuf Lisp files?
-Add more tests for merging from a protobuf instance. Use Stefil??
+Add more tests for merging from a protobuf instance.
Implement extensions
Add tests
Look at all XXXX comments in the compiler source and remove them.
involves filing some bugs against C++ code
-Use base::vector-index or eliminate it in protobuf Lisp files?
-
General stuff
=============
View
@@ -0,0 +1,74 @@
+;;;; Copyright 2011 Google Inc. All Rights Reserved
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;; * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; * Redistributions in binary form must reproduce the above
+;;;; copyright notice, this list of conditions and the following disclaimer
+;;;; in the documentation and/or other materials provided with the
+;;;; distribution.
+;;;; * Neither the name of Google Inc. nor the names of its
+;;;; contributors may be used to endorse or promote products derived from
+;;;; this software without specific prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;; Author: brown@google.com (Robert Brown)
+
+;;;; Floating point encoding and decoding for Lispworks.
+
+(in-package #:lispworks-float)
+(declaim #.*optimize-default*)
+
+(declaim (ftype (function (single-float) (values (signed-byte 32) &optional)) single-float-bits))
+
+(defun single-float-bits (x)
+ (declare (type single-float x))
+ ;; TODO(brown): Implement using Lispworks FLI functions.
+ (portable-float:single-float-bits x))
+
+(declaim (ftype (function (double-float) (values (signed-byte 64) &optional)) double-float-bits))
+
+(defun double-float-bits (x)
+ (declare (type double-float x))
+ ;; TODO(brown): Implement using Lispworks FLI functions.
+ (portable-float:double-float-bits x))
+
+(declaim (ftype (function ((signed-byte 32)) (values single-float &optional)) make-single-float))
+
+(defun make-single-float (bits)
+ (declare (type (signed-byte 32) bits))
+ (fli:with-dynamic-foreign-objects ((value :lisp-single-float))
+ (fli:with-coerced-pointer (pointer :type :uint32) value
+ (setf (fli:dereference pointer) bits))
+ (fli:dereference value)))
+
+(declaim (ftype (function ((signed-byte 32) (unsigned-byte 32)) (values double-float &optional))
+ make-double-float))
+
+(defun make-double-float (high-bits low-bits)
+ (declare (type (signed-byte 32) high-bits)
+ (type (unsigned-byte 32) low-bits))
+ (fli:with-dynamic-foreign-objects ((value :lisp-double-float))
+ (fli:with-coerced-pointer (pointer :type :uint32) value
+ ;; TODO(brown): Use the pointer type :uint64 above and remove the endian conditionals.
+ #+little-endian
+ (progn (setf (fli:dereference pointer :index 0) low-bits)
+ (setf (fli:dereference pointer :index 1) high-bits))
+ #-little-endian
+ (progn (setf (fli:dereference pointer :index 1) high-bits)
+ (setf (fli:dereference pointer :index 0) low-bits)))
+ (fli:dereference value)))
View
@@ -57,14 +57,14 @@
(defconst +golden-packed-file-name+
(merge-pathnames "google/protobuf/testdata/golden_packed_fields_message" +pwd+))
-(defparameter *optional-field-info*
+(defconst +optional-field-info+
;; field name, default value, value set by tests
'((optional-int32 0 101) (optional-int64 0 102)
(optional-uint32 0 103) (optional-uint64 0 104)
(optional-sint32 0 105) (optional-sint64 0 106)
(optional-fixed32 0 107) (optional-fixed64 0 108)
(optional-sfixed32 0 109) (optional-sfixed64 0 110)
- (optional-float 0s0 111s0) (optional-double 0d0 112d0)
+ (optional-float 0f0 111f0) (optional-double 0d0 112d0)
(optional-bool nil t)
(optional-string "" "115") (optional-bytes "" "116")
(optional-nested-enum #.pb:+testalltypes-nestedenum-foo+ #.pb:+testalltypes-nestedenum-baz+)
@@ -73,14 +73,14 @@
;; XXXX: C++ test does not verify these fields.
(optional-string-piece "" "124") (optional-cord "" "125")))
-(defparameter *default-field-info*
+(defconst +default-field-info+
;; field name, default value, value set by tests
'((default-int32 41 401) (default-int64 42 402)
(default-uint32 43 403) (default-uint64 44 404)
(default-sint32 -45 405) (default-sint64 46 406)
(default-fixed32 47 407) (default-fixed64 48 408)
(default-sfixed32 49 409) (default-sfixed64 -50 410)
- (default-float 51.5s0 411s0) (default-double 52d3 412d0)
+ (default-float 51.5f0 411f0) (default-double 52d3 412d0)
(default-bool t nil)
(default-string "hello" "415") (default-bytes "world" "416")
(default-nested-enum #.pb:+testalltypes-nestedenum-bar+ #.pb:+testalltypes-nestedenum-foo+)
@@ -89,14 +89,14 @@
;; XXXX: C++ test does not verify these fields.
(default-string-piece "abc" "424") (default-cord "123" "425")))
-(defparameter *repeated-field-info*
+(defconst +repeated-field-info+
;; field name, default value, value set by tests, modification value
'((repeated-int32 201 301 501) (repeated-int64 202 302 502)
(repeated-uint32 203 303 503) (repeated-uint64 204 304 504)
(repeated-sint32 205 305 505) (repeated-sint64 206 306 506)
(repeated-fixed32 207 307 507) (repeated-fixed64 208 308 508)
(repeated-sfixed32 209 309 509) (repeated-sfixed64 210 310 510)
- (repeated-float 211s0 311s0 511s0) (repeated-double 212d0 312d0 512d0)
+ (repeated-float 211f0 311f0 511f0) (repeated-double 212d0 312d0 512d0)
(repeated-bool t nil t)
(repeated-string
#.(string-to-utf8-octets "215")
@@ -144,7 +144,7 @@
(defun expect-all-fields-set (m)
;; optional and default fields
- (let ((field-info (append *optional-field-info* *default-field-info*)))
+ (let ((field-info (append +optional-field-info+ +default-field-info+)))
(loop for (field . values) in field-info do
(let ((has (field-function "HAS-" field))
(accessor (field-function "" field))
@@ -169,7 +169,7 @@
(is (= (pb:d (pb:optional-import-message m)) 120))
;; repeated fields
- (let ((field-info *repeated-field-info*))
+ (let ((field-info +repeated-field-info+))
(loop for (field . values) in field-info do
(let ((accessor (field-function "" field))
(v0 (first values))
@@ -200,7 +200,7 @@
(packed-sint32 605 705) (packed-sint64 606 706)
(packed-fixed32 607 707) (packed-fixed64 608 708)
(packed-sfixed32 609 709) (packed-sfixed64 610 710)
- (packed-float 611s0 711s0) (packed-double 612d0 712d0)
+ (packed-float 611f0 711f0) (packed-double 612d0 712d0)
(packed-bool t nil)
(packed-enum #.pb:+foreignenum-foreign-bar+ #.pb:+foreignenum-foreign-baz+)))
@@ -233,7 +233,7 @@
(defun set-all-fields (m)
;; optional and default fields
- (let ((field-info (append *optional-field-info* *default-field-info*)))
+ (let ((field-info (append +optional-field-info+ +default-field-info+)))
(loop for (field . values) in field-info do
(let ((setter (field-setter field))
(value (second values)))
@@ -244,7 +244,7 @@
(setf (pb:d (pb:optional-import-message m)) 120)
;; repeated fields
- (let ((field-info *repeated-field-info*))
+ (let ((field-info +repeated-field-info+))
(loop for (field . values) in field-info do
(let ((accessor (field-function "" field))
(v0 (first values))
@@ -289,7 +289,7 @@
(defun expect-clear (m)
;; optional and default fields
- (let ((field-info (append *optional-field-info* *default-field-info*)))
+ (let ((field-info (append +optional-field-info+ +default-field-info+)))
(loop for (field . values) in field-info do
(let ((has (field-function "HAS-" field))
(accessor (field-function "" field))
@@ -314,13 +314,13 @@
(is (= (pb:d (pb:optional-import-message m)) 0))
;; repeated fields
- (let ((field-info *repeated-field-info*))
+ (let ((field-info +repeated-field-info+))
(loop for (field . nil) in field-info do
(let ((accessor (field-function "" field)))
(is (zerop (length (funcall accessor m))))))))
(defun modify-repeated-fields (m)
- (let ((field-info *repeated-field-info*))
+ (let ((field-info +repeated-field-info+))
(loop for (field . values) in field-info do
(let ((accessor (field-function "" field))
(v (third values)))
@@ -331,7 +331,7 @@
(setf (pb::d (aref (pb:repeated-import-message m) 1)) 520))
(defun expect-repeated-fields-modified (m)
- (let ((field-info *repeated-field-info*))
+ (let ((field-info +repeated-field-info+))
(loop for (field . values) in field-info do
(let ((accessor (field-function "" field))
(v0 (first values))
View
@@ -1,48 +1,45 @@
+;;;; Copyright 2010, Google Inc. All rights reserved.
-;;;; package.lisp
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+;;;; * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; * Redistributions in binary form must reproduce the above
+;;;; copyright notice, this list of conditions and the following disclaimer
+;;;; in the documentation and/or other materials provided with the
+;;;; distribution.
+;;;; * Neither the name of Google Inc. nor the names of its
+;;;; contributors may be used to endorse or promote products derived from
+;;;; this software without specific prior written permission.
-;; Copyright 2010, Google Inc. All rights reserved.
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-
-;; * Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;; * Redistributions in binary form must reproduce the above
-;; copyright notice, this list of conditions and the following disclaimer
-;; in the documentation and/or other materials provided with the
-;; distribution.
-;; * Neither the name of Google Inc. nor the names of its
-;; contributors may be used to endorse or promote products derived from
-;; this software without specific prior written permission.
-
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;; Author: brown@google.com (Robert Brown)
(in-package #:common-lisp-user)
(defpackage #:protocol-buffer
- (:documentation "Machine generated protocol buffers")
+ (:documentation "Machine generated protocol buffers.")
(:nicknames #:pb)
- ;; We use no packages, not even COMMON-LISP, so machine-generated protocol
- ;; buffer code must explicitly qualify references to symbols outside the
- ;; PROTOCOL-BUFFER package. The benefit of this approach is that protocol
- ;; buffers can use field names such as SECOND or DEBUG, which live in the
- ;; COMMON-LISP package, without causing symbol conflicts.
+ ;; We use no packages, not even COMMON-LISP, so machine-generated protocol buffer code must
+ ;; explicitly qualify references to symbols outside the PROTOCOL-BUFFER package. The benefit of
+ ;; this approach is that protocol buffers can use field names such as SECOND or DEBUG, which live
+ ;; in the COMMON-LISP package, without causing symbol conflicts.
(:use)
- ;; Machine-generated protocol buffer code exports additional symbols for
- ;; each enum tag, protocol buffer constructor, field accessor, etc.
+ ;; Machine-generated protocol buffer code exports additional symbols for each enum tag, protocol
+ ;; buffer constructor, field accessor, etc.
(:export #:protocol-buffer
#:clear
#:is-initialized
@@ -52,15 +49,23 @@
#:serialize))
(defpackage #:portable-float
- (:documentation "Access the bits of IEEE floating point numbers")
- (:use #:common-lisp)
+ (:documentation "Portably access the bits of IEEE floating point numbers.")
+ (:use #:common-lisp #:com.google.base)
+ (:export #:single-float-bits
+ #:double-float-bits
+ #:make-single-float
+ #:make-double-float))
+
+(defpackage #:lispworks-float
+ (:documentation "Lispworks code to access the bits of IEEE floating point numbers.")
+ (:use #:common-lisp #:com.google.base)
(:export #:single-float-bits
#:double-float-bits
#:make-single-float
#:make-double-float))
(defpackage #:wire-format
- (:documentation "Wire format for protocol buffers")
+ (:documentation "Wire format for protocol buffers.")
(:use #:common-lisp #:com.google.base)
(:export ;; Conditions
#:protocol-error
View
@@ -1,14 +1,11 @@
+;;;; Portable floating point encoding and decoding.
-;;;; portable-float.lisp
-
-
-;; This software was extracted from the SBCL Common Lisp implementation,
-;; which was derived from the CMU Common Lisp system, which was written at
-;; Carnegie Mellon University and released into the public domain. The
-;; software in this file is in the public domain.
-
+;;;; This software was extracted from the SBCL Common Lisp implementation, which was derived from
+;;;; the CMU Common Lisp system, which was written at Carnegie Mellon University and released into
+;;;; the public domain. The software in this file is in the public domain.
(in-package #:portable-float)
+(declaim #.*optimize-default*)
(declaim (ftype (function (single-float) (values (signed-byte 32) &optional)) single-float-bits))
Oops, something went wrong.

0 comments on commit add374a

Please sign in to comment.