Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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...
commit add374a48289bc6d877debd5e4af50aa0ae909e2 1 parent a71dcc8
Robert Brown authored September 30, 2011
5  TODO
@@ -11,8 +11,9 @@ structure.
11 11
 
12 12
 Remove all references to the BASE package in generated code.  Make generated
13 13
 files independently loadable.
  14
+Use base::vector-index or eliminate it in protobuf Lisp files?
14 15
 
15  
-Add more tests for merging from a protobuf instance.  Use Stefil??
  16
+Add more tests for merging from a protobuf instance.
16 17
 
17 18
 Implement extensions
18 19
   Add tests
@@ -20,8 +21,6 @@ Implement extensions
20 21
 Look at all XXXX comments in the compiler source and remove them.
21 22
   involves filing some bugs against C++ code
22 23
 
23  
-Use base::vector-index or eliminate it in protobuf Lisp files?
24  
-
25 24
 
26 25
 General stuff
27 26
 =============
74  lispworks-float.lisp
... ...
@@ -0,0 +1,74 @@
  1
+;;;; Copyright 2011 Google Inc.  All Rights Reserved
  2
+
  3
+;;;; Redistribution and use in source and binary forms, with or without
  4
+;;;; modification, are permitted provided that the following conditions are
  5
+;;;; met:
  6
+
  7
+;;;;     * Redistributions of source code must retain the above copyright
  8
+;;;; notice, this list of conditions and the following disclaimer.
  9
+;;;;     * Redistributions in binary form must reproduce the above
  10
+;;;; copyright notice, this list of conditions and the following disclaimer
  11
+;;;; in the documentation and/or other materials provided with the
  12
+;;;; distribution.
  13
+;;;;     * Neither the name of Google Inc. nor the names of its
  14
+;;;; contributors may be used to endorse or promote products derived from
  15
+;;;; this software without specific prior written permission.
  16
+
  17
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
+
  29
+;;;; Author: brown@google.com (Robert Brown)
  30
+
  31
+;;;; Floating point encoding and decoding for Lispworks.
  32
+
  33
+(in-package #:lispworks-float)
  34
+(declaim #.*optimize-default*)
  35
+
  36
+(declaim (ftype (function (single-float) (values (signed-byte 32) &optional)) single-float-bits))
  37
+
  38
+(defun single-float-bits (x)
  39
+  (declare (type single-float x))
  40
+  ;; TODO(brown): Implement using Lispworks FLI functions.
  41
+  (portable-float:single-float-bits x))
  42
+
  43
+(declaim (ftype (function (double-float) (values (signed-byte 64) &optional)) double-float-bits))
  44
+
  45
+(defun double-float-bits (x)
  46
+  (declare (type double-float x))
  47
+  ;; TODO(brown): Implement using Lispworks FLI functions.
  48
+  (portable-float:double-float-bits x))
  49
+
  50
+(declaim (ftype (function ((signed-byte 32)) (values single-float &optional)) make-single-float))
  51
+
  52
+(defun make-single-float (bits)
  53
+  (declare (type (signed-byte 32) bits))
  54
+  (fli:with-dynamic-foreign-objects ((value :lisp-single-float))
  55
+    (fli:with-coerced-pointer (pointer :type :uint32) value
  56
+      (setf (fli:dereference pointer) bits))
  57
+    (fli:dereference value)))
  58
+
  59
+(declaim (ftype (function ((signed-byte 32) (unsigned-byte 32)) (values double-float &optional))
  60
+                make-double-float))
  61
+
  62
+(defun make-double-float (high-bits low-bits)
  63
+  (declare (type (signed-byte 32) high-bits)
  64
+           (type (unsigned-byte 32) low-bits))
  65
+  (fli:with-dynamic-foreign-objects ((value :lisp-double-float))
  66
+    (fli:with-coerced-pointer (pointer :type :uint32) value
  67
+      ;; TODO(brown): Use the pointer type :uint64 above and remove the endian conditionals.
  68
+      #+little-endian
  69
+      (progn (setf (fli:dereference pointer :index 0) low-bits)
  70
+             (setf (fli:dereference pointer :index 1) high-bits))
  71
+      #-little-endian
  72
+      (progn (setf (fli:dereference pointer :index 1) high-bits)
  73
+             (setf (fli:dereference pointer :index 0) low-bits)))
  74
+    (fli:dereference value)))
30  message-test.lisp
@@ -57,14 +57,14 @@
57 57
 (defconst +golden-packed-file-name+
58 58
   (merge-pathnames "google/protobuf/testdata/golden_packed_fields_message" +pwd+))
59 59
 
60  
-(defparameter *optional-field-info*
  60
+(defconst +optional-field-info+
61 61
   ;; field name, default value, value set by tests
62 62
   '((optional-int32 0 101) (optional-int64 0 102)
63 63
     (optional-uint32 0 103) (optional-uint64 0 104)
64 64
     (optional-sint32 0 105) (optional-sint64 0 106)
65 65
     (optional-fixed32 0 107) (optional-fixed64 0 108)
66 66
     (optional-sfixed32 0 109) (optional-sfixed64 0 110)
67  
-    (optional-float 0s0 111s0) (optional-double 0d0 112d0)
  67
+    (optional-float 0f0 111f0) (optional-double 0d0 112d0)
68 68
     (optional-bool nil t)
69 69
     (optional-string "" "115") (optional-bytes "" "116")
70 70
     (optional-nested-enum #.pb:+testalltypes-nestedenum-foo+ #.pb:+testalltypes-nestedenum-baz+)
@@ -73,14 +73,14 @@
73 73
     ;; XXXX: C++ test does not verify these fields.
74 74
     (optional-string-piece "" "124") (optional-cord "" "125")))
75 75
 
76  
-(defparameter *default-field-info*
  76
+(defconst +default-field-info+
77 77
   ;; field name, default value, value set by tests
78 78
   '((default-int32 41 401) (default-int64 42 402)
79 79
     (default-uint32 43 403) (default-uint64 44 404)
80 80
     (default-sint32 -45 405) (default-sint64 46 406)
81 81
     (default-fixed32 47 407) (default-fixed64 48 408)
82 82
     (default-sfixed32 49 409) (default-sfixed64 -50 410)
83  
-    (default-float 51.5s0 411s0) (default-double 52d3 412d0)
  83
+    (default-float 51.5f0 411f0) (default-double 52d3 412d0)
84 84
     (default-bool t nil)
85 85
     (default-string "hello" "415") (default-bytes "world" "416")
86 86
     (default-nested-enum #.pb:+testalltypes-nestedenum-bar+ #.pb:+testalltypes-nestedenum-foo+)
@@ -89,14 +89,14 @@
89 89
     ;; XXXX: C++ test does not verify these fields.
90 90
     (default-string-piece "abc" "424") (default-cord "123" "425")))
91 91
 
92  
-(defparameter *repeated-field-info*
  92
+(defconst +repeated-field-info+
93 93
   ;; field name, default value, value set by tests, modification value
94 94
   '((repeated-int32 201 301 501) (repeated-int64 202 302 502)
95 95
     (repeated-uint32 203 303 503) (repeated-uint64 204 304 504)
96 96
     (repeated-sint32 205 305 505) (repeated-sint64 206 306 506)
97 97
     (repeated-fixed32 207 307 507) (repeated-fixed64 208 308 508)
98 98
     (repeated-sfixed32 209 309 509) (repeated-sfixed64 210 310 510)
99  
-    (repeated-float 211s0 311s0 511s0) (repeated-double 212d0 312d0 512d0)
  99
+    (repeated-float 211f0 311f0 511f0) (repeated-double 212d0 312d0 512d0)
100 100
     (repeated-bool t nil t)
101 101
     (repeated-string
102 102
      #.(string-to-utf8-octets "215")
@@ -144,7 +144,7 @@
144 144
 
145 145
 (defun expect-all-fields-set (m)
146 146
   ;; optional and default fields
147  
-  (let ((field-info (append *optional-field-info* *default-field-info*)))
  147
+  (let ((field-info (append +optional-field-info+ +default-field-info+)))
148 148
     (loop for (field . values) in field-info do
149 149
           (let ((has (field-function "HAS-" field))
150 150
                 (accessor (field-function "" field))
@@ -169,7 +169,7 @@
169 169
   (is (= (pb:d (pb:optional-import-message m)) 120))
170 170
 
171 171
   ;; repeated fields
172  
-  (let ((field-info *repeated-field-info*))
  172
+  (let ((field-info +repeated-field-info+))
173 173
     (loop for (field . values) in field-info do
174 174
           (let ((accessor (field-function "" field))
175 175
                 (v0 (first values))
@@ -200,7 +200,7 @@
200 200
     (packed-sint32 605 705) (packed-sint64 606 706)
201 201
     (packed-fixed32 607 707) (packed-fixed64 608 708)
202 202
     (packed-sfixed32 609 709) (packed-sfixed64 610 710)
203  
-    (packed-float 611s0 711s0) (packed-double 612d0 712d0)
  203
+    (packed-float 611f0 711f0) (packed-double 612d0 712d0)
204 204
     (packed-bool t nil)
205 205
     (packed-enum #.pb:+foreignenum-foreign-bar+ #.pb:+foreignenum-foreign-baz+)))
206 206
 
@@ -233,7 +233,7 @@
233 233
 
234 234
 (defun set-all-fields (m)
235 235
   ;; optional and default fields
236  
-  (let ((field-info (append *optional-field-info* *default-field-info*)))
  236
+  (let ((field-info (append +optional-field-info+ +default-field-info+)))
237 237
     (loop for (field . values) in field-info do
238 238
           (let ((setter (field-setter field))
239 239
                 (value (second values)))
@@ -244,7 +244,7 @@
244 244
   (setf (pb:d (pb:optional-import-message m)) 120)
245 245
 
246 246
   ;; repeated fields
247  
-  (let ((field-info *repeated-field-info*))
  247
+  (let ((field-info +repeated-field-info+))
248 248
     (loop for (field . values) in field-info do
249 249
           (let ((accessor (field-function "" field))
250 250
                 (v0 (first values))
@@ -289,7 +289,7 @@
289 289
 
290 290
 (defun expect-clear (m)
291 291
   ;; optional and default fields
292  
-  (let ((field-info (append *optional-field-info* *default-field-info*)))
  292
+  (let ((field-info (append +optional-field-info+ +default-field-info+)))
293 293
     (loop for (field . values) in field-info do
294 294
           (let ((has (field-function "HAS-" field))
295 295
                 (accessor (field-function "" field))
@@ -314,13 +314,13 @@
314 314
   (is (= (pb:d (pb:optional-import-message m)) 0))
315 315
 
316 316
   ;; repeated fields
317  
-  (let ((field-info *repeated-field-info*))
  317
+  (let ((field-info +repeated-field-info+))
318 318
     (loop for (field . nil) in field-info do
319 319
           (let ((accessor (field-function "" field)))
320 320
             (is (zerop (length (funcall accessor m))))))))
321 321
 
322 322
 (defun modify-repeated-fields (m)
323  
-  (let ((field-info *repeated-field-info*))
  323
+  (let ((field-info +repeated-field-info+))
324 324
     (loop for (field . values) in field-info do
325 325
           (let ((accessor (field-function "" field))
326 326
                 (v (third values)))
@@ -331,7 +331,7 @@
331 331
   (setf (pb::d (aref (pb:repeated-import-message m) 1)) 520))
332 332
 
333 333
 (defun expect-repeated-fields-modified (m)
334  
-  (let ((field-info *repeated-field-info*))
  334
+  (let ((field-info +repeated-field-info+))
335 335
     (loop for (field . values) in field-info do
336 336
           (let ((accessor (field-function "" field))
337 337
                 (v0 (first values))
81  package.lisp
... ...
@@ -1,48 +1,45 @@
  1
+;;;; Copyright 2010, Google Inc. All rights reserved.
1 2
 
2  
-;;;;    package.lisp
  3
+;;;; Redistribution and use in source and binary forms, with or without
  4
+;;;; modification, are permitted provided that the following conditions are
  5
+;;;; met:
3 6
 
  7
+;;;;     * Redistributions of source code must retain the above copyright
  8
+;;;; notice, this list of conditions and the following disclaimer.
  9
+;;;;     * Redistributions in binary form must reproduce the above
  10
+;;;; copyright notice, this list of conditions and the following disclaimer
  11
+;;;; in the documentation and/or other materials provided with the
  12
+;;;; distribution.
  13
+;;;;     * Neither the name of Google Inc. nor the names of its
  14
+;;;; contributors may be used to endorse or promote products derived from
  15
+;;;; this software without specific prior written permission.
4 16
 
5  
-;; Copyright 2010, Google Inc. All rights reserved.
  17
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
6 28
 
7  
-;; Redistribution and use in source and binary forms, with or without
8  
-;; modification, are permitted provided that the following conditions are
9  
-;; met:
10  
-
11  
-;;     * Redistributions of source code must retain the above copyright
12  
-;; notice, this list of conditions and the following disclaimer.
13  
-;;     * Redistributions in binary form must reproduce the above
14  
-;; copyright notice, this list of conditions and the following disclaimer
15  
-;; in the documentation and/or other materials provided with the
16  
-;; distribution.
17  
-;;     * Neither the name of Google Inc. nor the names of its
18  
-;; contributors may be used to endorse or promote products derived from
19  
-;; this software without specific prior written permission.
20  
-
21  
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22  
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23  
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24  
-;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25  
-;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26  
-;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27  
-;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28  
-;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29  
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30  
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31  
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
+;;;; Author: brown@google.com (Robert Brown)
32 30
 
33 31
 (in-package #:common-lisp-user)
34 32
 
35 33
 (defpackage #:protocol-buffer
36  
-  (:documentation "Machine generated protocol buffers")
  34
+  (:documentation "Machine generated protocol buffers.")
37 35
   (:nicknames #:pb)
38  
-  ;; We use no packages, not even COMMON-LISP, so machine-generated protocol
39  
-  ;; buffer code must explicitly qualify references to symbols outside the
40  
-  ;; PROTOCOL-BUFFER package.  The benefit of this approach is that protocol
41  
-  ;; buffers can use field names such as SECOND or DEBUG, which live in the
42  
-  ;; COMMON-LISP package, without causing symbol conflicts.
  36
+  ;; We use no packages, not even COMMON-LISP, so machine-generated protocol buffer code must
  37
+  ;; explicitly qualify references to symbols outside the PROTOCOL-BUFFER package.  The benefit of
  38
+  ;; this approach is that protocol buffers can use field names such as SECOND or DEBUG, which live
  39
+  ;; in the COMMON-LISP package, without causing symbol conflicts.
43 40
   (:use)
44  
-  ;; Machine-generated protocol buffer code exports additional symbols for
45  
-  ;; each enum tag, protocol buffer constructor, field accessor, etc.
  41
+  ;; Machine-generated protocol buffer code exports additional symbols for each enum tag, protocol
  42
+  ;; buffer constructor, field accessor, etc.
46 43
   (:export #:protocol-buffer
47 44
            #:clear
48 45
            #:is-initialized
@@ -52,15 +49,23 @@
52 49
            #:serialize))
53 50
 
54 51
 (defpackage #:portable-float
55  
-  (:documentation "Access the bits of IEEE floating point numbers")
56  
-  (:use #:common-lisp)
  52
+  (:documentation "Portably access the bits of IEEE floating point numbers.")
  53
+  (:use #:common-lisp #:com.google.base)
  54
+  (:export #:single-float-bits
  55
+           #:double-float-bits
  56
+           #:make-single-float
  57
+           #:make-double-float))
  58
+
  59
+(defpackage #:lispworks-float
  60
+  (:documentation "Lispworks code to access the bits of IEEE floating point numbers.")
  61
+  (:use #:common-lisp #:com.google.base)
57 62
   (:export #:single-float-bits
58 63
            #:double-float-bits
59 64
            #:make-single-float
60 65
            #:make-double-float))
61 66
 
62 67
 (defpackage #:wire-format
63  
-  (:documentation "Wire format for protocol buffers")
  68
+  (:documentation "Wire format for protocol buffers.")
64 69
   (:use #:common-lisp #:com.google.base)
65 70
   (:export ;; Conditions
66 71
            #:protocol-error
13  portable-float.lisp
... ...
@@ -1,14 +1,11 @@
  1
+;;;; Portable floating point encoding and decoding.
1 2
 
2  
-;;;;    portable-float.lisp
3  
-
4  
-
5  
-;; This software was extracted from the SBCL Common Lisp implementation,
6  
-;; which was derived from the CMU Common Lisp system, which was written at
7  
-;; Carnegie Mellon University and released into the public domain. The
8  
-;; software in this file is in the public domain.
9  
-
  3
+;;;; This software was extracted from the SBCL Common Lisp implementation, which was derived from
  4
+;;;; the CMU Common Lisp system, which was written at Carnegie Mellon University and released into
  5
+;;;; the public domain.  The software in this file is in the public domain.
10 6
 
11 7
 (in-package #:portable-float)
  8
+(declaim #.*optimize-default*)
12 9
 
13 10
 (declaim (ftype (function (single-float) (values (signed-byte 32) &optional)) single-float-bits))
14 11
 
74  protobuf.asd
... ...
@@ -1,34 +1,32 @@
1  
-
2  
-;;;;    protobuf.asd
3  
-
4  
-
5  
-;; Copyright 2010, Google Inc. All rights reserved.
6  
-
7  
-;; Redistribution and use in source and binary forms, with or without
8  
-;; modification, are permitted provided that the following conditions are
9  
-;; met:
10  
-
11  
-;;     * Redistributions of source code must retain the above copyright
12  
-;; notice, this list of conditions and the following disclaimer.
13  
-;;     * Redistributions in binary form must reproduce the above
14  
-;; copyright notice, this list of conditions and the following disclaimer
15  
-;; in the documentation and/or other materials provided with the
16  
-;; distribution.
17  
-;;     * Neither the name of Google Inc. nor the names of its
18  
-;; contributors may be used to endorse or promote products derived from
19  
-;; this software without specific prior written permission.
20  
-
21  
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22  
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23  
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24  
-;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25  
-;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26  
-;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27  
-;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28  
-;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29  
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30  
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31  
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  1
+;;;; Copyright 2011 Google Inc.  All Rights Reserved
  2
+
  3
+;;;; Redistribution and use in source and binary forms, with or without
  4
+;;;; modification, are permitted provided that the following conditions are
  5
+;;;; met:
  6
+
  7
+;;;;     * Redistributions of source code must retain the above copyright
  8
+;;;; notice, this list of conditions and the following disclaimer.
  9
+;;;;     * Redistributions in binary form must reproduce the above
  10
+;;;; copyright notice, this list of conditions and the following disclaimer
  11
+;;;; in the documentation and/or other materials provided with the
  12
+;;;; distribution.
  13
+;;;;     * Neither the name of Google Inc. nor the names of its
  14
+;;;; contributors may be used to endorse or promote products derived from
  15
+;;;; this software without specific prior written permission.
  16
+
  17
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
+
  29
+;;;; Author: brown@google.com (Robert Brown)
32 30
 
33 31
 (cl:in-package #:asdf)
34 32
 
@@ -215,7 +213,7 @@ LOAD-OP, which means ASDF loads both the .lisp file and the .fasl file."
215 213
   :name "Protocol Buffer"
216 214
   :description "Protocol buffer code"
217 215
   :long-description "A Common Lisp implementation of Google's protocol buffer support libraries."
218  
-  :version "0.7.1"
  216
+  :version "0.7.2"
219 217
   :author "Robert Brown"
220 218
   :license "See file COPYING and the copyright messages in individual files."
221 219
   ;; After loading the system, announce its availability.
@@ -231,10 +229,10 @@ LOAD-OP, which means ASDF loads both the .lisp file and the .fasl file."
231 229
    (:static-file "README")
232 230
    (:static-file "TODO")
233 231
    (:file "package")
234  
-   #-(or abcl allegro cmu sbcl)
235  
-   (:module "sysdep"
236  
-    :pathname ""           ; this module's files are not in a subdirectory
237  
-    :depends-on ("package")
238  
-    :components ((:file "portable-float")))
239 232
    (:file "protocol-buffer" :depends-on ("package"))
240  
-   (:file "wire-format" :depends-on ("package" #-(or abcl allegro cmu sbcl) "sysdep"))))
  233
+   #-(or abcl allegro cmu sbcl) (:file "portable-float" :depends-on ("package"))
  234
+   #+lispworks (:file "lispworks-float" :depends-on ("package"))
  235
+   (:file "wire-format"
  236
+    :depends-on ("package"
  237
+                 #-(or abcl allegro cmu sbcl) "portable-float"
  238
+                 #+lispworks "lispworks-float"))))
4  protoc/lisp/helpers.cc
@@ -160,11 +160,11 @@ string LispSimpleFtoa(float value) {
160 160
 
161 161
   string::size_type pos = c_result.find("e", 0);
162 162
   if (pos != string::npos) {
163  
-    c_result.replace(pos, 1, "s");
  163
+    c_result.replace(pos, 1, "f");
164 164
     return c_result;
165 165
   }
166 166
 
167  
-  return c_result + "s0";
  167
+  return c_result + "f0";
168 168
 }
169 169
 
170 170
 string LispSimpleDtoa(double value) {
90  wire-format.lisp
... ...
@@ -1,35 +1,34 @@
1  
-
2  
-;;;;    wire-format.lisp
3  
-
4  
-
5  
-;; Copyright 2010, Google Inc. All rights reserved.
6  
-
7  
-;; Redistribution and use in source and binary forms, with or without
8  
-;; modification, are permitted provided that the following conditions are
9  
-;; met:
10  
-
11  
-;;     * Redistributions of source code must retain the above copyright
12  
-;; notice, this list of conditions and the following disclaimer.
13  
-;;     * Redistributions in binary form must reproduce the above
14  
-;; copyright notice, this list of conditions and the following disclaimer
15  
-;; in the documentation and/or other materials provided with the
16  
-;; distribution.
17  
-;;     * Neither the name of Google Inc. nor the names of its
18  
-;; contributors may be used to endorse or promote products derived from
19  
-;; this software without specific prior written permission.
20  
-
21  
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22  
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23  
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24  
-;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25  
-;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26  
-;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27  
-;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28  
-;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29  
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30  
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31  
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32  
-
  1
+;;;; Copyright 2011 Google Inc.  All Rights Reserved
  2
+
  3
+;;;; Redistribution and use in source and binary forms, with or without
  4
+;;;; modification, are permitted provided that the following conditions are
  5
+;;;; met:
  6
+
  7
+;;;;     * Redistributions of source code must retain the above copyright
  8
+;;;; notice, this list of conditions and the following disclaimer.
  9
+;;;;     * Redistributions in binary form must reproduce the above
  10
+;;;; copyright notice, this list of conditions and the following disclaimer
  11
+;;;; in the documentation and/or other materials provided with the
  12
+;;;; distribution.
  13
+;;;;     * Neither the name of Google Inc. nor the names of its
  14
+;;;; contributors may be used to endorse or promote products derived from
  15
+;;;; this software without specific prior written permission.
  16
+
  17
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
+
  29
+;;;; Author: brown@google.com (Robert Brown)
  30
+
  31
+;;;; Wire format used when reading and writing protobuf data.
33 32
 
34 33
 (in-package #:wire-format)
35 34
 (declaim #.*optimize-default*)
@@ -374,15 +373,14 @@ LIMIT, then signal ENCODE-OVERFLOW."
374 373
            (type single-float float))
375 374
   (when (> (+ index 4) limit)
376 375
     (error 'buffer-overflow))
377  
-  (let ((bits #-(or abcl allegro cmu sbcl)
378  
-              (portable-float:single-float-bits float)
  376
+  (let ((bits #-(or abcl allegro cmu lispworks sbcl) (portable-float:single-float-bits float)
379 377
               #+abcl (system:single-float-bits float)
380  
-              #+allegro
381  
-              (multiple-value-bind (high low)
382  
-                  (excl:single-float-to-shorts float)
383  
-                (declare (type (unsigned-byte 16) high low))
384  
-                (logior (ash high 16) low))
  378
+              #+allegro (multiple-value-bind (high low)
  379
+                            (excl:single-float-to-shorts float)
  380
+                          (declare (type (unsigned-byte 16) high low))
  381
+                          (logior (ash high 16) low))
385 382
               #+cmu (kernel:single-float-bits float)
  383
+              #+lispworks (lispworks-float:single-float-bits float)
386 384
               #+sbcl (sb-kernel:single-float-bits float)))
387 385
     (declare (type #-allegro int32 #+allegro uint32 bits))
388 386
     (setf (aref buffer index) (ldb (byte 8 0) bits))
@@ -417,7 +415,7 @@ LIMIT, then signal ENCODE-OVERFLOW."
417 415
         (high 0))
418 416
     (declare (type uint32 low)
419 417
              (type #-allegro int32 #+allegro uint32 high))
420  
-    #-(or abcl allegro cmu sbcl)
  418
+    #-(or abcl allegro cmu lispworks sbcl)
421 419
     (let ((bits (portable-float:double-float-bits float)))
422 420
       (setf low (logand #xffffffff bits))
423 421
       (setf high (ash bits -32)))
@@ -433,6 +431,10 @@ LIMIT, then signal ENCODE-OVERFLOW."
433 431
     #+cmu
434 432
     (progn (setf low (kernel:double-float-low-bits float))
435 433
            (setf high (kernel:double-float-high-bits float)))
  434
+    #+lispworks
  435
+    (let ((bits (lispworks-float:double-float-bits float)))
  436
+      (setf low (logand #xffffffff bits))
  437
+      (setf high (ash bits -32)))
436 438
     #+sbcl
437 439
     (progn (setf low (sb-kernel:double-float-low-bits float))
438 440
            (setf high (sb-kernel:double-float-high-bits float)))
@@ -482,7 +484,7 @@ PARSE-OVERFLOW."
482 484
     ;; BITS must have the correct sign.
483 485
     (when (= (ldb (byte 1 31) bits) 1)    ; sign bit set, so negative value
484 486
       (decf bits (ash 1 32)))
485  
-    #-(or abcl allegro cmu sbcl)
  487
+    #-(or abcl allegro cmu lispworks sbcl)
486 488
     (values (portable-float:make-single-float bits) index)
487 489
     #+abcl
488 490
     (values (system:make-single-float bits) index)
@@ -492,6 +494,8 @@ PARSE-OVERFLOW."
492 494
             index)
493 495
     #+cmu
494 496
     (values (kernel:make-single-float bits) index)
  497
+    #+lispworks
  498
+    (values (lispworks-float:make-single-float bits) index)
495 499
     #+sbcl
496 500
     (values (sb-kernel:make-single-float bits) index)))
497 501
 
@@ -531,7 +535,7 @@ PARSE-OVERFLOW."
531 535
       ;; High bits are signed, but low bits are unsigned.
532 536
       (when (= (ldb (byte 1 31) high) 1)    ; sign bit set, so negative value
533 537
         (decf high (ash 1 32)))
534  
-      #-(or abcl allegro cmu sbcl)
  538
+      #-(or abcl allegro cmu lispworks sbcl)
535 539
       (values (portable-float:make-double-float high low) index)
536 540
       #+abcl
537 541
       (values (system:make-double-float (logior (ash high 32) low)) index)
@@ -543,6 +547,8 @@ PARSE-OVERFLOW."
543 547
               index)
544 548
       #+cmu
545 549
       (values (kernel:make-double-float high low) index)
  550
+      #+lispworks
  551
+      (values (lispworks-float:make-double-float high low) index)
546 552
       #+sbcl
547 553
       (values (sb-kernel:make-double-float high low) index))))
548 554
 

0 notes on commit add374a

Please sign in to comment.
Something went wrong with that request. Please try again.