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 ;;; Functional programming, please
263 (defun curry (function &rest args)
264 "Returns a function that applies 'function' to 'args', plus any
265 additional arguments given at the call site."
266 (if (and args (null (cdr args))) ;fast test for length = 1
267 (let ((arg (car args)))
268 #'(lambda (&rest more-args)
269 (apply function arg more-args)))
270 #'(lambda (&rest more-args)
271 (apply function (append args more-args)))))
273 (define-compiler-macro curry (&whole form function &rest args &environment env)
274 (declare (ignore env))
275 (if (and (listp function)
276 (eq (first function) 'function)
277 (symbolp (second function))
278 (and args (null (cdr args))))
279 `#'(lambda (&rest more-args)
280 (apply ,function ,(car args) more-args))
286 ;; A parameterized list type for repeated fields
287 ;; The elements aren't type-checked
288 (deftype list-of (type)
289 (if (eq type 'nil) ;a list that cannot have any element (element-type nil) is null
293 ;; The same, but use a (stretchy) vector
294 (deftype vector-of (type)
295 (if (eq type 'nil) ;an array that cannot have any element (element-type nil) is of size 0
297 '(array * (*)))) ;a 1-dimensional array of any type
299 ;; This corresponds to the :bytes Protobufs type
300 (deftype byte-vector () '(array (unsigned-byte 8) (*)))
302 (defun make-byte-vector (size)
303 (make-array size :element-type '(unsigned-byte 8)))
305 ;; The Protobufs integer types
306 (deftype int32 () '(signed-byte 32))
307 (deftype int64 () '(signed-byte 64))
308 (deftype uint32 () '(unsigned-byte 32))
309 (deftype uint64 () '(unsigned-byte 64))
310 (deftype sint32 () '(signed-byte 32))
311 (deftype sint64 () '(signed-byte 64))
312 (deftype fixed32 () '(signed-byte 32))
313 (deftype fixed64 () '(signed-byte 64))
314 (deftype sfixed32 () '(signed-byte 32))
315 (deftype sfixed64 () '(signed-byte 64))
318 (defun type-expand (type)
319 #+allegro (excl:normalize-type type :default type)
320 #+ccl (ccl::type-expand type)
321 #+clisp (ext:type-expand type)
322 #+cmu (kernel:type-expand type)
323 #+lispworks (type:expand-user-type type)
324 #+sbcl (sb-ext:typexpand type)
325 #-(or allegro ccl clisp cmu lispworks sbcl) type)
327 ;;; Code generation utilities
329 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
330 (defvar *camel-case-field-names* nil)
332 (defun find-proto-package (name)
333 "A very fuzzy definition of 'find-package'."
336 ;; Try looking under the given name and the all-uppercase name
337 (or (find-package (string name))
338 (find-package (string-upcase (string name)))))
340 ;; If 'name' is a list, it's actually a fully-qualified path
341 (or (find-proto-package (first name))
342 (find-proto-package (format nil "~{~A~^.~}" name))))))
344 ;; "class-name" -> "ClassName", ("ClassName")
345 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
346 (defun class-name->proto (x)
347 "Given a Lisp class name, returns a Protobufs message or enum name.
348 The second value is the fully qualified name, as a list."
349 (let* ((xs (split-string (string x) :separators '(#\.)))
350 (ns (loop for x in (butlast xs)
351 collect (remove-if-not #'alphanumericp
352 (camel-case (format nil "~A" x) *proto-name-separators*))))
354 (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
355 (values name (append ns (list name))
356 ;; This might be the name of a package, too
357 (format nil "~{~A~^.~}" (butlast xs)))))
359 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
360 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
361 (defun enum-name->proto (x &optional prefix)
362 "Given a Lisp enum value name, returns a Protobufs enum value name.
363 The second value is the fully qualified name, as a list."
364 (let* ((xs (split-string (string x) :separators '(#\.)))
365 (ns (loop for x in (butlast xs)
366 collect (remove-if-not #'alphanumericp
367 (camel-case (format nil "~A" x) *proto-name-separators*))))
368 (nx (string-upcase (car (last xs))))
369 (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
370 ;; Keep underscores, they are standards separators in Protobufs enum names
371 (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
372 (format nil "~{~A~^_~}"
373 (split-string nx :separators *proto-name-separators*)))))
374 (values name (append ns (list name))
375 (format nil "~{~A~^.~}" (butlast xs)))))
377 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
378 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
379 (defun slot-name->proto (x)
380 "Given a Lisp slot name, returns a Protobufs field name.
381 The second value is the fully qualified name, as a list."
382 (let* ((xs (split-string (string x) :separators '(#\.)))
383 (ns (loop for x in (butlast xs)
384 collect (remove-if-not #'alphanumericp
385 (camel-case (format nil "~A" x) *proto-name-separators*))))
386 (nx (string-downcase (car (last xs))))
387 (name (if *camel-case-field-names*
388 (remove-if-not #'alphanumericp
389 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
390 ;; Keep underscores, they are standards separators in Protobufs field names
391 (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
392 (format nil "~{~A~^_~}"
393 (split-string nx :separators *proto-name-separators*))))))
394 (values name (append ns (list name))
395 (format nil "~{~A~^.~}" (butlast xs)))))
398 ;; "ClassName" -> 'class-name
399 ;; "cl-user.ClassName" -> 'cl-user::class-name
400 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
401 (defun proto->class-name (x &optional package)
402 "Given a Protobufs message or enum type name, returns a Lisp class or type name.
403 This resolves Protobufs qualified names as best as it can."
404 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
406 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
407 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
408 (package (or pkg1 pkgn package))
409 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
410 (values (if package (intern name package) (make-symbol name)) package xs
411 ;; This might be the name of a package, too
412 (format nil "~{~A~^.~}" (butlast xs)))))
414 ;; "ENUM_VALUE" -> :enum-value
415 ;; "cl-user.ENUM_VALUE" -> :enum-value
416 ;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
417 (defun proto->enum-name (x &optional package)
418 "Given a Protobufs enum value name, returns a Lisp enum value name.
419 This resolves Protobufs qualified names as best as it can."
420 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
422 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
423 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
424 (package (or pkg1 pkgn package))
425 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
426 (values (kintern name) package xs
427 (format nil "~{~A~^.~}" (butlast xs)))))
429 ;; "slot_name" or "slotName" -> 'slot-name
430 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
431 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
432 (defun proto->slot-name (x &optional package)
433 "Given a Protobufs field value name, returns a Lisp slot name.
434 This resolves Protobufs qualified names as best as it can."
435 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
437 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
438 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
439 (package (or pkg1 pkgn package))
440 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
441 (values (if package (intern name package) (make-symbol name)) package xs
442 (format nil "~{~A~^.~}" (butlast xs)))))
447 (define-condition protobufs-warning (warning simple-condition) ())
449 (defun protobufs-warn (format-control &rest format-arguments)
450 (warn 'protobufs-warning
451 :format-control format-control
452 :format-arguments format-arguments))
455 #-(or allegro lispworks)
456 (defmacro without-redefinition-warnings (() &body body)
460 (defmacro without-redefinition-warnings (() &body body)
461 `(excl:without-redefinition-warnings ,@body))
464 (defmacro without-redefinition-warnings (() &body body)
465 `(let ((dspec:*redefinition-action* :quiet)) ,@body))
468 ;;; Portable floating point utilities
470 #+(or abcl allegro ccl cmu sbcl lispworks)
471 (defun single-float-bits (x)
472 (declare (type single-float x))
473 #+abcl (system:single-float-bits x)
474 #+allegro (multiple-value-bind (high low)
475 (excl:single-float-to-shorts x)
476 (declare (type (unsigned-byte 16) high low))
477 (logior (ash high 16) low))
478 #+ccl (ccl::single-float-bits x)
479 #+cmu (kernel:single-float-bits x)
480 #+sbcl (sb-kernel:single-float-bits x)
481 #+lispworks (lispworks-float:single-float-bits x))
483 #-(or abcl allegro ccl cmu sbcl lispworks)
484 (defun single-float-bits (x)
485 (declare (type single-float x))
486 (assert (= (float-radix x) 2))
488 (if (eql x 0.0f0) 0 #x-80000000)
489 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
490 (integer-decode-float x)
491 (assert (plusp lisp-significand))
492 (let* ((significand lisp-significand)
493 (exponent (+ lisp-exponent 23 127))
495 (if (plusp exponent) ;if not obviously denormalized
498 ;; Special termination case for denormalized float number
500 ;; Denormalized numbers have exponent one greater than
501 ;; in the exponent field
502 (return (ash significand -1)))
503 ;; Ordinary termination case
504 ((>= significand (expt 2 23))
505 (assert (< 0 significand (expt 2 24)))
506 ;; Exponent 0 is reserved for denormalized numbers,
507 ;; and 255 is reserved for specials like NaN
508 (assert (< 0 exponent 255))
509 (return (logior (ash exponent 23)
510 (logand significand (1- (ash 1 23))))))
512 ;; Shift as necessary to set bit 24 of significand
513 (setq significand (ash significand 1)
514 exponent (1- exponent)))))
515 (do () ((zerop exponent)
516 ;; Denormalized numbers have exponent one greater than
517 ;; the exponent field
518 (ash significand -1))
519 (unless (zerop (logand significand 1))
520 (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
521 (setq significand (ash significand -1)
522 exponent (1+ exponent))))))
524 ((1) unsigned-result)
525 ((-1) (logior unsigned-result (- (expt 2 31)))))))))
528 #+(or abcl allegro ccl cmu sbcl lispworks)
529 (defun double-float-bits (x)
530 (declare (type double-float x))
531 #+abcl (values (system:double-float-low-bits x)
532 (system:double-float-high-bits x))
533 #+allegro (multiple-value-bind (us3 us2 us1 us0)
534 (excl:double-float-to-shorts x)
535 (logior (ash us1 16) us0)
536 (logior (ash us3 16) us2))
537 #+ccl (multiple-value-bind (high low)
538 (ccl::double-float-bits x)
540 #+cmu (values (kernel:double-float-low-bits x)
541 (kernel:double-float-high-bits x))
542 #+sbcl (values (sb-kernel:double-float-low-bits x)
543 (sb-kernel:double-float-high-bits x))
544 #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
545 (values (logand #xffffffff bits)
548 #-(or abcl allegro ccl cmu sbcl lispworks)
549 (defun double-float-bits (x)
550 (declare (type double-float x))
551 (assert (= (float-radix x) 2))
553 (if (eql x 0.0d0) 0 #x-8000000000000000)
554 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
555 (integer-decode-float x)
556 (assert (plusp lisp-significand))
557 (let* ((significand lisp-significand)
558 (exponent (+ lisp-exponent 52 1023))
560 (if (plusp exponent) ;if not obviously denormalized
563 ;; Special termination case for denormalized float number
565 ;; Denormalized numbers have exponent one greater than
566 ;; in the exponent field
567 (return (ash significand -1)))
568 ;; Ordinary termination case
569 ((>= significand (expt 2 52))
570 (assert (< 0 significand (expt 2 53)))
571 ;; Exponent 0 is reserved for denormalized numbers,
572 ;; and 2047 is reserved for specials like NaN
573 (assert (< 0 exponent 2047))
574 (return (logior (ash exponent 52)
575 (logand significand (1- (ash 1 52))))))
577 ;; Shift as necessary to set bit 53 of significand
578 (setq significand (ash significand 1)
579 exponent (1- exponent)))))
580 (do () ((zerop exponent)
581 ;; Denormalized numbers have exponent one greater than
582 ;; the exponent field
583 (ash significand -1))
584 (unless (zerop (logand significand 1))
585 (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
586 (setq significand (ash significand -1)
587 exponent (1+ exponent))))))
590 ((1) unsigned-result)
591 ((-1) (logior unsigned-result (- (expt 2 63)))))))
592 ;; Return the low bits and the high bits
593 (values (logand #xffffffff result) (ash result -32)))))))
596 #+(or abcl allegro ccl cmu sbcl lispworks)
597 (defun make-single-float (bits)
598 (declare (type (signed-byte 32) bits))
599 #+abcl (system:make-single-float bits)
600 #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
601 (ldb (byte 16 0) bits))
602 #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits)
603 #+cmu (kernel:make-single-float bits)
604 #+sbcl (sb-kernel:make-single-float bits)
605 #+lispworks (lispworks-float:make-single-float bits))
607 #-(or abcl allegro ccl cmu sbcl lispworks)
608 (defun make-single-float (bits)
609 (declare (type (signed-byte 32) bits))
611 ;; IEEE float special cases
613 ((= bits #x-80000000) -0.0)
615 (let* ((sign (ecase (ldb (byte 1 31) bits)
618 (iexpt (ldb (byte 8 23) bits))
619 (exponent (if (zerop iexpt) ;denormalized
622 (mantissa (* (logior (ldb (byte 23 0) bits)
623 (if (zerop iexpt) 0 (ash 1 23)))
625 (* sign (expt 2.0 exponent) mantissa)))))
628 #+(or abcl allegro ccl cmu sbcl lispworks)
629 (defun make-double-float (low high)
630 (declare (type (unsigned-byte 32) low)
631 (type (signed-byte 32) high))
632 #+abcl (system:make-double-float (logior (ash high 32) low))
633 #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
634 (ldb (byte 16 0) high)
635 (ldb (byte 16 16) low)
636 (ldb (byte 16 0) low))
637 #+ccl (ccl::double-float-from-bits high low)
638 #+cmu (kernel:make-double-float high low)
639 #+sbcl (sb-kernel:make-double-float high low)
640 #+lispworks (lispworks-float:make-double-float high low))
642 #-(or abcl allegro ccl cmu sbcl lispworks)
643 (defun make-double-float (low high)
644 (declare (type (unsigned-byte 32) low)
645 (type (signed-byte 32) high))
647 ;; IEEE float special cases
648 ((and (zerop high) (zerop low)) 0.0d0)
649 ((and (= high #x-80000000)
652 (let* ((bits (logior (ash high 32) low))
653 (sign (ecase (ldb (byte 1 63) bits)
656 (iexpt (ldb (byte 11 52) bits))
657 (exponent (if (zerop iexpt) ;denormalized
660 (mantissa (* (logior (ldb (byte 52 0) bits)
661 (if (zerop iexpt) 0 (ash 1 52)))
663 (* sign (expt 2.0d0 exponent) mantissa)))))