1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Optimized fixnum arithmetic
16 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defparameter $optimize-default '(optimize (speed 1) (safety 3) (debug 3))
19 "Compiler optimization settings for safe, debuggable code.")
20 (defparameter $optimize-fast-unsafe '(optimize (speed 3) (safety 0) (debug 0))
21 "Compiler optimization settings for fast, unsafe, hard-to-debug code.")
26 (defmacro i+ (&rest fixnums)
27 `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
29 (defmacro i- (number &rest fixnums)
30 `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
32 (defmacro i* (&rest fixnums)
33 `(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n)))))
35 (defmacro i= (&rest fixnums)
36 `(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
38 (defmacro i< (&rest fixnums)
39 `(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
41 (defmacro i<= (&rest fixnums)
42 `(<= ,@(loop for n in fixnums collect `(the fixnum ,n))))
44 (defmacro i> (&rest fixnums)
45 `(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
47 (defmacro i>= (&rest fixnums)
48 `(>= ,@(loop for n in fixnums collect `(the fixnum ,n))))
50 (defmacro iash (value count)
51 `(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
53 (defmacro ilogior (&rest fixnums)
55 `(the fixnum (logior (the fixnum ,(car fixnums))
57 `(ilogior ,@(cdr fixnums))
58 `(the fixnum ,(cadr fixnums)))))
59 `(the fixnum ,(car fixnums))))
61 (defmacro ilogand (&rest fixnums)
63 `(the fixnum (logand (the fixnum ,(car fixnums))
65 `(ilogand ,@(cdr fixnums))
66 `(the fixnum ,(cadr fixnums)))))
67 `(the fixnum ,(car fixnums))))
69 (define-modify-macro iincf (&optional (delta 1)) i+)
70 (define-modify-macro idecf (&optional (delta 1)) i-)
72 (defmacro ildb (bytespec value)
73 `(the fixnum (ldb ,bytespec (the fixnum ,value))))
78 (defun starts-with (string prefix &key (start 0))
79 "Returns true if 'string' starts with the prefix 'prefix' (case insensitive)."
80 (and (i>= (length string) (i+ start (length prefix)))
81 (string-equal string prefix :start1 start :end1 (i+ start (length prefix)))
84 (defun ends-with (string suffix &key (end (length string)))
85 "Returns true if 'string' ends with the prefix 'prefix' (case insensitive)."
86 (and (i>= end (length suffix))
87 (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
90 (defun strcat (&rest strings)
91 "Concatenate a bunch of strings."
92 (declare (dynamic-extent strings))
93 (apply #'concatenate 'string strings))
96 ;; (camel-case "camel-case") => "CamelCase"
97 (defun camel-case (string &optional (separators '(#\-)))
98 "Take a hyphen-separated string and turn it into a camel-case string."
99 (let ((words (split-string string :separators separators)))
100 (format nil "~{~@(~A~)~}" words)))
102 ;; (camel-case-but-one "camel-case") => "camelCase"
103 (defun camel-case-but-one (string &optional (separators '(#\-)))
104 "Take a hyphen-separated string and turn its tail into a camel-case string."
105 (let ((words (split-string string :separators separators)))
106 (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
109 ;; (uncamel-case "CamelCase") => "CAMEL-CASE"
110 ;; (uncamel-case "TCPConnection") => "TCP-CONNECTION"
111 ;; (uncamel-case "NewTCPConnection") => "NEW-TCP-CONNECTION"
112 ;; (uncamel-case "new_RPC_LispService") => "NEW-RPC-LISP-SERVICE"
113 ;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
114 ;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
115 (defun uncamel-case (name)
116 "Take a camel-case string and turn it into a hyphen-separated string."
117 ;; We need a whole state machine to get this right
118 (labels ((uncamel (chars state result)
119 (let ((ch (first chars)))
123 (uncamel (rest chars) 'upper
126 ;; "TCPConnection" => "TCP-CONNECTION"
127 (if (and (second chars) (lower-case-p (second chars)))
128 (list* ch #\- result)
130 ((lower digit) (list* ch #\- result))
131 (otherwise (cons ch result)))))
133 (uncamel (rest chars) 'lower
134 (cons (char-upcase ch) result)))
136 (uncamel (rest chars) 'digit
138 ((or (eql ch #\-) (eql ch #\_))
139 (uncamel (rest chars) 'dash
142 (uncamel (rest chars) 'dot
145 (error "Invalid name character: ~A" ch))))))
146 (strcat (nreverse (uncamel (concatenate 'list name) nil ())))))
149 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
150 "Given a string 'string', splits it at each of the separators.
151 Returns a list of the string pieces, with empty pieces removed."
152 (unless (i= start end)
153 (loop for this fixnum = start then (i+ next 1)
154 for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
155 :start this :end end)
157 for piece = (string-right-trim '(#\space) (subseq line this next))
158 when (not (i= (length piece) 0))
160 until (i>= next end))))
165 (defmacro with-gensyms ((&rest bindings) &body body)
166 `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
169 (defun make-lisp-symbol (string)
170 "Intern a string of the 'package:string' and return the symbol."
171 (let* ((string (string string))
172 (colon (position #\: string))
173 (pkg (if colon (subseq string 0 colon) "KEYWORD"))
174 (sym (if colon (subseq string (+ colon 1)) string)))
177 (defun fintern (format-string &rest format-args)
178 "Interns a new symbol in the current package."
179 (declare (dynamic-extent format-args))
180 (intern (nstring-upcase (apply #'format nil format-string format-args))))
182 (defun kintern (format-string &rest format-args)
183 "Interns a new symbol in the keyword package."
184 (declare (dynamic-extent format-args))
185 (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
187 (defun keywordify (x)
188 "Given a symbol designator 'x', return a keyword whose name is 'x'.
189 If 'x' is nil, this returns nil."
190 (check-type x (or string symbol null))
193 ((symbolp x) (keywordify (symbol-name x)))
194 ((zerop (length x)) nil)
195 ((string-not-equal x "nil")
196 (intern (string-upcase x) (find-package "KEYWORD")))
202 (defmacro with-collectors ((&rest collection-descriptions) &body body)
203 "'collection-descriptions' is a list of clauses of the form (coll function).
204 The body can call each 'function' to add a value to 'coll'. 'function'
205 runs in constant time, regardless of the length of the list."
206 (let ((let-bindings ())
210 (dolist (description collection-descriptions)
211 (destructuring-bind (place name) description
212 (let ((vtail (make-symbol (format nil "~A-TAIL" place))))
213 (setq dynamic-extents
214 (nconc dynamic-extents `(#',name)))
222 (setq ,vtail (if ,vtail
223 (setf (cdr ,vtail) (list ,vobj))
224 (setf ,place (list ,vobj)))))))))))
225 `(let (,@let-bindings)
226 (flet (,@flet-bindings)
227 ,@(and dynamic-extents
228 `((declare (dynamic-extent ,@dynamic-extents))))
231 (defmacro with-prefixed-accessors (names (prefix object) &body body)
232 `(with-accessors (,@(loop for name in names
233 collect `(,name ,(fintern "~A~A" prefix name))))
237 (defmacro dovector ((var vector &optional value) &body body)
238 "Like 'dolist', but iterates over the vector 'vector'."
239 (with-gensyms (vidx vlen vvec)
240 `(let* ((,vvec ,vector)
241 (,vlen (length ,vvec)))
242 (loop for ,vidx fixnum from 0 below ,vlen
243 as ,var = (aref ,vvec ,vidx)
245 finally (return ,value)))))
247 (defmacro doseq ((var sequence &optional value) &body body)
248 "Iterates over a sequence, using 'dolist' or 'dovector' depending on
249 the type of the sequence. In optimized code, this turns out to be
250 faster than (map () #'f sequence).
251 Note that the body gets expanded twice!"
253 `(let ((,vseq ,sequence))
255 (dovector (,var ,vseq ,value)
257 (dolist (,var ,vseq ,value)
261 (defmacro appendf (place tail)
262 "Append 'tail' to the list given by 'place', then set the place to the new list."
263 `(setf ,place (append ,place ,tail)))
266 ;;; Functional programming, please
268 (defun curry (function &rest args)
269 "Returns a function that applies 'function' to 'args', plus any
270 additional arguments given at the call site."
271 (if (and args (null (cdr args))) ;fast test for length = 1
272 (let ((arg (car args)))
273 #'(lambda (&rest more-args)
274 (apply function arg more-args)))
275 #'(lambda (&rest more-args)
276 (apply function (append args more-args)))))
278 (define-compiler-macro curry (&whole form function &rest args &environment env)
279 (declare (ignore env))
280 (if (and (listp function)
281 (eq (first function) 'function)
282 (symbolp (second function))
283 (and args (null (cdr args))))
284 `#'(lambda (&rest more-args)
285 (apply ,function ,(car args) more-args))
291 ;; A parameterized list type for repeated fields
292 ;; The elements aren't type-checked
293 (deftype list-of (type)
294 (if (eq type 'nil) ;a list that cannot have any element (element-type nil) is null
298 ;; The same, but use a (stretchy) vector
299 (deftype vector-of (type)
300 (if (eq type 'nil) ;an array that cannot have any element (element-type nil) is of size 0
302 '(array * (*)))) ;a 1-dimensional array of any type
304 ;; This corresponds to the :bytes Protobufs type
305 (deftype byte-vector () '(array (unsigned-byte 8) (*)))
307 (defun make-byte-vector (size)
308 (make-array size :element-type '(unsigned-byte 8)))
310 ;; The Protobufs integer types
311 (deftype int32 () '(signed-byte 32))
312 (deftype int64 () '(signed-byte 64))
313 (deftype uint32 () '(unsigned-byte 32))
314 (deftype uint64 () '(unsigned-byte 64))
315 (deftype sint32 () '(signed-byte 32))
316 (deftype sint64 () '(signed-byte 64))
317 (deftype fixed32 () '(signed-byte 32))
318 (deftype fixed64 () '(signed-byte 64))
319 (deftype sfixed32 () '(signed-byte 32))
320 (deftype sfixed64 () '(signed-byte 64))
323 (defun type-expand (type)
324 #+allegro (excl:normalize-type type :default type)
325 #+ccl (ccl::type-expand type)
326 #+clisp (ext:type-expand type)
327 #+cmu (kernel:type-expand type)
328 #+lispworks (type:expand-user-type type)
329 #+sbcl (sb-ext:typexpand type)
330 #-(or allegro ccl clisp cmu lispworks sbcl) type)
333 ;;; Code generation utilities
335 (defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
336 (defparameter *camel-case-field-names* nil)
338 (defun find-proto-package (name)
339 "A very fuzzy definition of 'find-package'."
342 ;; Try looking under the given name and the all-uppercase name
343 (or (find-package (string name))
344 (find-package (string-upcase (string name)))))
346 ;; If 'name' is a list, it's actually a fully-qualified path
347 (or (find-proto-package (first name))
348 (find-proto-package (format nil "~{~A~^.~}" name))))))
350 ;; "class-name" -> "ClassName", ("ClassName")
351 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
352 (defun class-name->proto (x)
353 "Given a Lisp class name, returns a Protobufs message or enum name.
354 The second value is the fully qualified name, as a list."
355 (let* ((xs (split-string (string x) :separators '(#\.)))
356 (ns (loop for x in (butlast xs)
357 collect (remove-if-not #'alphanumericp
358 (camel-case (format nil "~A" x) *proto-name-separators*))))
360 (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
361 (values name (append ns (list name))
362 ;; This might be the name of a package, too
363 (format nil "~{~A~^.~}" (butlast xs)))))
365 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
366 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
367 (defun enum-name->proto (x &optional prefix)
368 "Given a Lisp enum value name, returns a Protobufs enum value name.
369 The second value is the fully qualified name, as a list."
370 (let* ((xs (split-string (string x) :separators '(#\.)))
371 (ns (loop for x in (butlast xs)
372 collect (remove-if-not #'alphanumericp
373 (camel-case (format nil "~A" x) *proto-name-separators*))))
374 (nx (string-upcase (car (last xs))))
375 (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
376 ;; Keep underscores, they are standards separators in Protobufs enum names
377 (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
378 (format nil "~{~A~^_~}"
379 (split-string nx :separators *proto-name-separators*)))))
380 (values name (append ns (list name))
381 (format nil "~{~A~^.~}" (butlast xs)))))
383 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
384 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
385 (defun slot-name->proto (x)
386 "Given a Lisp slot name, returns a Protobufs field name.
387 The second value is the fully qualified name, as a list."
388 (let* ((xs (split-string (string x) :separators '(#\.)))
389 (ns (loop for x in (butlast xs)
390 collect (remove-if-not #'alphanumericp
391 (camel-case (format nil "~A" x) *proto-name-separators*))))
392 (nx (string-downcase (car (last xs))))
393 (name (if *camel-case-field-names*
394 (remove-if-not #'alphanumericp
395 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
396 ;; Keep underscores, they are standards separators in Protobufs field names
397 (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
398 (format nil "~{~A~^_~}"
399 (split-string nx :separators *proto-name-separators*))))))
400 (values name (append ns (list name))
401 (format nil "~{~A~^.~}" (butlast xs)))))
404 ;; "ClassName" -> 'class-name
405 ;; "cl-user.ClassName" -> 'cl-user::class-name
406 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
407 (defun proto->class-name (x &optional package)
408 "Given a Protobufs message or enum type name, returns a Lisp class or type name.
409 This resolves Protobufs qualified names as best as it can."
410 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
412 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
413 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
414 (package (or pkg1 pkgn package))
415 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
416 (values (if package (intern name package) (make-symbol name)) package xs
417 ;; This might be the name of a package, too
418 (format nil "~{~A~^.~}" (butlast xs)))))
420 ;; "ENUM_VALUE" -> :enum-value
421 ;; "cl-user.ENUM_VALUE" -> :enum-value
422 ;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
423 (defun proto->enum-name (x &optional package)
424 "Given a Protobufs enum value name, returns a Lisp enum value name.
425 This resolves Protobufs qualified names as best as it can."
426 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
428 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
429 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
430 (package (or pkg1 pkgn package))
431 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
432 (values (kintern name) package xs
433 (format nil "~{~A~^.~}" (butlast xs)))))
435 ;; "slot_name" or "slotName" -> 'slot-name
436 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
437 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
438 (defun proto->slot-name (x &optional package)
439 "Given a Protobufs field value name, returns a Lisp slot name.
440 This resolves Protobufs qualified names as best as it can."
441 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
443 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
444 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
445 (package (or pkg1 pkgn package))
446 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
447 (values (if package (intern name package) (make-symbol name)) package xs
448 (format nil "~{~A~^.~}" (butlast xs)))))
453 (define-condition protobufs-warning (warning simple-condition) ())
455 (defun protobufs-warn (format-control &rest format-arguments)
456 (warn 'protobufs-warning
457 :format-control format-control
458 :format-arguments format-arguments))
461 #-(or allegro lispworks)
462 (defmacro without-redefinition-warnings (() &body body)
466 (defmacro without-redefinition-warnings (() &body body)
467 `(excl:without-redefinition-warnings ,@body))
470 (defmacro without-redefinition-warnings (() &body body)
471 `(let ((dspec:*redefinition-action* :quiet)) ,@body))
474 ;;; Portable floating point utilities
476 #+(or abcl allegro ccl cmu sbcl lispworks)
477 (defun single-float-bits (x)
478 (declare (type single-float x))
479 #+abcl (system:single-float-bits x)
480 #+allegro (multiple-value-bind (high low)
481 (excl:single-float-to-shorts x)
482 (declare (type (unsigned-byte 16) high low))
483 (logior (ash high 16) low))
484 #+ccl (ccl::single-float-bits x)
485 #+cmu (kernel:single-float-bits x)
486 #+sbcl (sb-kernel:single-float-bits x)
487 #+lispworks (lispworks-float:single-float-bits x))
489 #-(or abcl allegro ccl cmu sbcl lispworks)
490 (defun single-float-bits (x)
491 (declare (type single-float x))
492 (assert (= (float-radix x) 2))
494 (if (eql x 0.0f0) 0 #x-80000000)
495 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
496 (integer-decode-float x)
497 (assert (plusp lisp-significand))
498 (let* ((significand lisp-significand)
499 (exponent (+ lisp-exponent 23 127))
501 (if (plusp exponent) ;if not obviously denormalized
504 ;; Special termination case for denormalized float number
506 ;; Denormalized numbers have exponent one greater than
507 ;; in the exponent field
508 (return (ash significand -1)))
509 ;; Ordinary termination case
510 ((>= significand (expt 2 23))
511 (assert (< 0 significand (expt 2 24)))
512 ;; Exponent 0 is reserved for denormalized numbers,
513 ;; and 255 is reserved for specials like NaN
514 (assert (< 0 exponent 255))
515 (return (logior (ash exponent 23)
516 (logand significand (1- (ash 1 23))))))
518 ;; Shift as necessary to set bit 24 of significand
519 (setq significand (ash significand 1)
520 exponent (1- exponent)))))
521 (do () ((zerop exponent)
522 ;; Denormalized numbers have exponent one greater than
523 ;; the exponent field
524 (ash significand -1))
525 (unless (zerop (logand significand 1))
526 (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
527 (setq significand (ash significand -1)
528 exponent (1+ exponent))))))
530 ((1) unsigned-result)
531 ((-1) (logior unsigned-result (- (expt 2 31)))))))))
534 #+(or abcl allegro ccl cmu sbcl lispworks)
535 (defun double-float-bits (x)
536 (declare (type double-float x))
537 #+abcl (values (system:double-float-low-bits x)
538 (system:double-float-high-bits x))
539 #+allegro (multiple-value-bind (us3 us2 us1 us0)
540 (excl:double-float-to-shorts x)
541 (logior (ash us1 16) us0)
542 (logior (ash us3 16) us2))
543 #+ccl (multiple-value-bind (high low)
544 (ccl::double-float-bits x)
546 #+cmu (values (kernel:double-float-low-bits x)
547 (kernel:double-float-high-bits x))
548 #+sbcl (values (sb-kernel:double-float-low-bits x)
549 (sb-kernel:double-float-high-bits x))
550 #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
551 (values (logand #xffffffff bits)
554 #-(or abcl allegro ccl cmu sbcl lispworks)
555 (defun double-float-bits (x)
556 (declare (type double-float x))
557 (assert (= (float-radix x) 2))
559 (if (eql x 0.0d0) 0 #x-8000000000000000)
560 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
561 (integer-decode-float x)
562 (assert (plusp lisp-significand))
563 (let* ((significand lisp-significand)
564 (exponent (+ lisp-exponent 52 1023))
566 (if (plusp exponent) ;if not obviously denormalized
569 ;; Special termination case for denormalized float number
571 ;; Denormalized numbers have exponent one greater than
572 ;; in the exponent field
573 (return (ash significand -1)))
574 ;; Ordinary termination case
575 ((>= significand (expt 2 52))
576 (assert (< 0 significand (expt 2 53)))
577 ;; Exponent 0 is reserved for denormalized numbers,
578 ;; and 2047 is reserved for specials like NaN
579 (assert (< 0 exponent 2047))
580 (return (logior (ash exponent 52)
581 (logand significand (1- (ash 1 52))))))
583 ;; Shift as necessary to set bit 53 of significand
584 (setq significand (ash significand 1)
585 exponent (1- exponent)))))
586 (do () ((zerop exponent)
587 ;; Denormalized numbers have exponent one greater than
588 ;; the exponent field
589 (ash significand -1))
590 (unless (zerop (logand significand 1))
591 (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
592 (setq significand (ash significand -1)
593 exponent (1+ exponent))))))
596 ((1) unsigned-result)
597 ((-1) (logior unsigned-result (- (expt 2 63)))))))
598 ;; Return the low bits and the high bits
599 (values (logand #xffffffff result) (ash result -32)))))))
602 #+(or abcl allegro ccl cmu sbcl lispworks)
603 (defun make-single-float (bits)
604 (declare (type (signed-byte 32) bits))
605 #+abcl (system:make-single-float bits)
606 #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
607 (ldb (byte 16 0) bits))
608 #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits)
609 #+cmu (kernel:make-single-float bits)
610 #+sbcl (sb-kernel:make-single-float bits)
611 #+lispworks (lispworks-float:make-single-float bits))
613 #-(or abcl allegro ccl cmu sbcl lispworks)
614 (defun make-single-float (bits)
615 (declare (type (signed-byte 32) bits))
617 ;; IEEE float special cases
619 ((= bits #x-80000000) -0.0)
621 (let* ((sign (ecase (ldb (byte 1 31) bits)
624 (iexpt (ldb (byte 8 23) bits))
625 (exponent (if (zerop iexpt) ;denormalized
628 (mantissa (* (logior (ldb (byte 23 0) bits)
629 (if (zerop iexpt) 0 (ash 1 23)))
631 (* sign (expt 2.0 exponent) mantissa)))))
634 #+(or abcl allegro ccl cmu sbcl lispworks)
635 (defun make-double-float (low high)
636 (declare (type (unsigned-byte 32) low)
637 (type (signed-byte 32) high))
638 #+abcl (system:make-double-float (logior (ash high 32) low))
639 #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
640 (ldb (byte 16 0) high)
641 (ldb (byte 16 16) low)
642 (ldb (byte 16 0) low))
643 #+ccl (ccl::double-float-from-bits (logand high #xffffffff) low)
644 #+cmu (kernel:make-double-float high low)
645 #+sbcl (sb-kernel:make-double-float high low)
646 #+lispworks (lispworks-float:make-double-float high low))
648 #-(or abcl allegro ccl cmu sbcl lispworks)
649 (defun make-double-float (low high)
650 (declare (type (unsigned-byte 32) low)
651 (type (signed-byte 32) high))
653 ;; IEEE float special cases
654 ((and (zerop high) (zerop low)) 0.0d0)
655 ((and (= high #x-80000000)
658 (let* ((bits (logior (ash high 32) low))
659 (sign (ecase (ldb (byte 1 63) bits)
662 (iexpt (ldb (byte 11 52) bits))
663 (exponent (if (zerop iexpt) ;denormalized
666 (mantissa (* (logior (ldb (byte 52 0) bits)
667 (if (zerop iexpt) 0 (ash 1 52)))
669 (* sign (expt 2.0d0 exponent) mantissa)))))