1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
16 (defun class-name->proto (x)
17 "Given a Lisp class name, returns a Protobufs message or enum name."
18 (remove-if-not #'alphanumericp
19 (camel-case (format nil "~A" x) :separators '(#\- #\_ #\/))))
21 (defun enum-name->proto (x &optional prefix)
22 "Given a Lisp enum value name, returns a Protobufs enum value name."
23 (let* ((x (string-upcase (string x)))
24 (x (if (and prefix (starts-with x prefix)) (subseq x (length prefix)) x)))
25 (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
26 (format nil "~{~A~^_~}" (split-string x :separators '(#\- #\_ #\/ #\.))))))
28 (defun slot-name->proto (x)
29 "Given a Lisp slot name, returns a Protobufs field name."
30 (remove-if-not #'alphanumericp
31 (camel-case-but-one (format nil "~A" x) :separators '(#\- #\_ #\/ #\.))))
34 (defun proto->class-name (x &optional package)
35 "Given a Protobufs message or enum type name, returns a Lisp class or type name."
36 (let ((name (string-upcase (uncamel-case x))))
37 (if package (intern name package) (make-symbol name))))
39 (defun proto->enum-name (x &optional package)
40 "Given a Protobufs enum value name, returns a Lisp enum value name."
41 (let ((name (format nil "~{~A~^-~}" (split-string (string-upcase x) :separators '(#\_)))))
42 (if package (intern name package) (make-symbol name))))
44 (defun proto->slot-name (x &optional package)
45 "Given a Protobufs field value name, returns a Lisp slot name."
46 (let ((name (string-upcase (uncamel-case x))))
47 (if package (intern name package) (make-symbol name))))
50 (define-condition protobufs-warning (warning simple-condition) ())
52 (defun protobufs-warn (format-control &rest format-arguments)
53 (warn 'protobufs-warning
54 :format-control format-control
55 :format-arguments format-arguments))
61 (defmacro i+ (&rest fixnums)
62 `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
64 (defmacro i- (number &rest fixnums)
65 `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
67 (defmacro i= (&rest fixnums)
68 `(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
70 (defmacro i< (&rest fixnums)
71 `(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
73 (defmacro i> (&rest fixnums)
74 `(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
76 (defmacro iash (value count)
77 `(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
79 (defmacro ilogior (&rest fixnums)
81 `(the fixnum (logior (the fixnum ,(car fixnums))
83 `(ilogior ,@(cdr fixnums))
84 `(the fixnum ,(cadr fixnums)))))
85 `(the fixnum ,(car fixnums))))
87 (defmacro ilogand (&rest fixnums)
89 `(the fixnum (logand (the fixnum ,(car fixnums))
91 `(ilogand ,@(cdr fixnums))
92 `(the fixnum ,(cadr fixnums)))))
93 `(the fixnum ,(car fixnums))))
95 (define-modify-macro iincf (&optional (delta 1)) i+)
96 (define-modify-macro idecf (&optional (delta 1)) i-)
101 ;;; Floating point utilities
103 #+(or abcl allegro cmu sbcl lispworks)
104 (defun single-float-bits (x)
105 (declare (type single-float x))
106 #+abcl (system:single-float-bits float)
107 #+allegro (multiple-value-bind (high low)
108 (excl:single-float-to-shorts float)
109 (declare (type (unsigned-byte 16) high low))
110 (logior (ash high 16) low))
111 #+cmu (kernel:single-float-bits float)
112 #+sbcl (sb-kernel:single-float-bits float)
113 #+lispworks (lispworks-float:single-float-bits float))
115 #-(or abcl allegro cmu sbcl lispworks)
116 (defun single-float-bits (x)
117 (declare (type single-float x))
118 (assert (= (float-radix x) 2))
120 (if (eql x 0.0f0) 0 #x-80000000)
121 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
122 (integer-decode-float x)
123 (assert (plusp lisp-significand))
124 (let* ((significand lisp-significand)
125 (exponent (+ lisp-exponent 23 127))
127 (if (plusp exponent) ;if not obviously denormalized
130 ;; Special termination case for denormalized float number
132 ;; Denormalized numbers have exponent one greater than
133 ;; in the exponent field
134 (return (ash significand -1)))
135 ;; Ordinary termination case
136 ((>= significand (expt 2 23))
137 (assert (< 0 significand (expt 2 24)))
138 ;; Exponent 0 is reserved for denormalized numbers,
139 ;; and 255 is reserved for specials like NaN
140 (assert (< 0 exponent 255))
141 (return (logior (ash exponent 23)
142 (logand significand (1- (ash 1 23))))))
144 ;; Shift as necessary to set bit 24 of significand
145 (setq significand (ash significand 1)
146 exponent (1- exponent)))))
147 (do () ((zerop exponent)
148 ;; Denormalized numbers have exponent one greater than
149 ;; the exponent field
150 (ash significand -1))
151 (unless (zerop (logand significand 1))
152 (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
153 (setq significand (ash significand -1)
154 exponent (1+ exponent))))))
156 ((1) unsigned-result)
157 ((-1) (logior unsigned-result (- (expt 2 31)))))))))
160 #+(or abcl allegro cmu sbcl lispworks)
161 (defun double-float-bits (x)
162 (declare (type double-float x))
163 #+abcl (values (system:double-float-low-bits float)
164 (system:double-float-high-bits float))
165 #+allegro (multiple-value-bind (us3 us2 us1 us0)
166 (excl:double-float-to-shorts float)
167 (logior (ash us1 16) us0)
168 (logior (ash us3 16) us2))
169 #+cmu (values (kernel:double-float-low-bits float)
170 (kernel:double-float-high-bits float))
171 #+sbcl (values (sb-kernel:double-float-low-bits float)
172 (sb-kernel:double-float-high-bits float))
173 #+lispworks (let ((bits (lispworks-float:double-float-bits float)))
174 (values (logand #xffffffff bits)
177 #-(or abcl allegro cmu sbcl lispworks)
178 (defun double-float-bits (x)
179 (declare (type double-float x))
180 (assert (= (float-radix x) 2))
182 (if (eql x 0.0d0) 0 #x-8000000000000000)
183 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
184 (integer-decode-float x)
185 (assert (plusp lisp-significand))
186 (let* ((significand lisp-significand)
187 (exponent (+ lisp-exponent 52 1023))
189 (if (plusp exponent) ;if not obviously denormalized
192 ;; Special termination case for denormalized float number
194 ;; Denormalized numbers have exponent one greater than
195 ;; in the exponent field
196 (return (ash significand -1)))
197 ;; Ordinary termination case
198 ((>= significand (expt 2 52))
199 (assert (< 0 significand (expt 2 53)))
200 ;; Exponent 0 is reserved for denormalized numbers,
201 ;; and 2047 is reserved for specials like NaN
202 (assert (< 0 exponent 2047))
203 (return (logior (ash exponent 52)
204 (logand significand (1- (ash 1 52))))))
206 ;; Shift as necessary to set bit 53 of significand
207 (setq significand (ash significand 1)
208 exponent (1- exponent)))))
209 (do () ((zerop exponent)
210 ;; Denormalized numbers have exponent one greater than
211 ;; the exponent field
212 (ash significand -1))
213 (unless (zerop (logand significand 1))
214 (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
215 (setq significand (ash significand -1)
216 exponent (1+ exponent))))))
219 ((1) unsigned-result)
220 ((-1) (logior unsigned-result (- (expt 2 63)))))))
221 ;; Return the low bits and the high bits
222 (values (logand #xffffffff result) (ash result -32)))))))
225 #+(or abcl allegro cmu sbcl lispworks)
226 (defun make-single-float (bits)
227 (declare (type (signed-byte 32) bits))
228 #+abcl (system:make-single-float bits)
229 #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
230 (ldb (byte 16 0) bits))
231 #+cmu (kernel:make-single-float bits)
232 #+sbcl (sb-kernel:make-single-float bits)
233 #+lispworks (lispworks-float:make-single-float bits))
235 #-(or abcl allegro cmu sbcl lispworks)
236 (defun make-single-float (bits)
237 (declare (type (signed-byte 32) bits))
239 ;; IEEE float special cases
241 ((= bits #x-80000000) -0.0)
243 (let* ((sign (ecase (ldb (byte 1 31) bits)
246 (iexpt (ldb (byte 8 23) bits))
247 (exponent (if (zerop iexpt) ;denormalized
250 (mantissa (* (logior (ldb (byte 23 0) bits)
251 (if (zerop iexpt) 0 (ash 1 23)))
253 (* sign (expt 2.0 exponent) mantissa)))))
256 #+(or abcl allegro cmu sbcl lispworks)
257 (defun make-double-float (low-bits high-bits)
258 (declare (type (unsigned-byte 32) low-bits)
259 (type (signed-byte 32) high-bits))
260 #+abcl (system:make-double-float (logior (ash high 32) low))
261 #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
262 (ldb (byte 16 0) high)
263 (ldb (byte 16 16) low)
264 (ldb (byte 16 0) low))
265 #+cmu (kernel:make-double-float high low)
266 #+sbcl (sb-kernel:make-double-float high low)
267 #+lispworks (lispworks-float:make-double-float high low))
269 #-(or abcl allegro cmu sbcl lispworks)
270 (defun make-double-float (low-bits high-bits)
271 (declare (type (unsigned-byte 32) low-bits)
272 (type (signed-byte 32) high-bits))
274 ;; IEEE float special cases
275 ((and (zerop high-bits) (zerop low-bits)) 0.0d0)
276 ((and (= high-bits #x-80000000)
277 (zerop low-bits)) -0.0d0)
279 (let* ((bits (logior (ash high-bits 32) low-bits))
280 (sign (ecase (ldb (byte 1 63) bits)
283 (iexpt (ldb (byte 11 52) bits))
284 (exponent (if (zerop iexpt) ;denormalized
287 (mantissa (* (logior (ldb (byte 52 0) bits)
288 (if (zerop iexpt) 0 (ash 1 52)))
290 (* sign (expt 2.0d0 exponent) mantissa)))))