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))))
75 (defmacro ilogbitp (index integer)
76 `(logbitp ,index (the fixnum ,integer)))
80 (defun starts-with (string prefix &key (start 0))
81 "Returns true if 'string' starts with the prefix 'prefix' (case insensitive)."
82 (and (i>= (length string) (i+ start (length prefix)))
83 (string-equal string prefix :start1 start :end1 (i+ start (length prefix)))
86 (defun ends-with (string suffix &key (end (length string)))
87 "Returns true if 'string' ends with the prefix 'prefix' (case insensitive)."
88 (and (i>= end (length suffix))
89 (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
92 (defun strcat (&rest strings)
93 "Concatenate a bunch of strings."
94 (declare (dynamic-extent strings))
95 (apply #'concatenate 'string strings))
98 ;; (camel-case "camel-case") => "CamelCase"
99 (defun camel-case (string &optional (separators '(#\-)))
100 "Take a hyphen-separated string and turn it into a camel-case string."
101 (let ((words (split-string string :separators separators)))
102 (format nil "~{~@(~A~)~}" words)))
104 ;; (camel-case-but-one "camel-case") => "camelCase"
105 (defun camel-case-but-one (string &optional (separators '(#\-)))
106 "Take a hyphen-separated string and turn its tail into a camel-case string."
107 (let ((words (split-string string :separators separators)))
108 (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
111 ;; (uncamel-case "CamelCase") => "CAMEL-CASE"
112 ;; (uncamel-case "TCPConnection") => "TCP-CONNECTION"
113 ;; (uncamel-case "NewTCPConnection") => "NEW-TCP-CONNECTION"
114 ;; (uncamel-case "new_RPC_LispService") => "NEW-RPC-LISP-SERVICE"
115 ;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
116 ;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
117 (defun uncamel-case (name)
118 "Take a camel-case string and turn it into a hyphen-separated string."
119 ;; We need a whole state machine to get this right
120 (labels ((uncamel (chars state result)
121 (let ((ch (first chars)))
125 (uncamel (rest chars) 'upper
128 ;; "TCPConnection" => "TCP-CONNECTION"
129 (if (and (second chars) (lower-case-p (second chars)))
130 (list* ch #\- result)
132 ((lower digit) (list* ch #\- result))
133 (otherwise (cons ch result)))))
135 (uncamel (rest chars) 'lower
136 (cons (char-upcase ch) result)))
138 (uncamel (rest chars) 'digit
140 ((or (eql ch #\-) (eql ch #\_))
141 (uncamel (rest chars) 'dash
144 (uncamel (rest chars) 'dot
147 (error "Invalid name character: ~A" ch))))))
148 (strcat (nreverse (uncamel (concatenate 'list name) nil ())))))
151 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
152 "Given a string 'string', splits it at each of the separators.
153 Returns a list of the string pieces, with empty pieces removed."
154 (unless (i= start end)
155 (loop for this fixnum = start then (i+ next 1)
156 for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
157 :start this :end end)
159 for piece = (string-right-trim '(#\space) (subseq line this next))
160 when (not (i= (length piece) 0))
162 until (i>= next end))))
167 (defmacro with-gensyms ((&rest bindings) &body body)
168 `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
171 (defun make-lisp-symbol (string)
172 "Intern a string of the 'package:string' and return the symbol."
173 (let* ((string (string string))
174 (colon (position #\: string))
175 (pkg (if colon (subseq string 0 colon) "KEYWORD"))
176 (sym (if colon (subseq string (+ colon 1)) string)))
179 (defun fintern (format-string &rest format-args)
180 "Interns a new symbol in the current package."
181 (declare (dynamic-extent format-args))
182 (intern (nstring-upcase (apply #'format nil format-string format-args))))
184 (defun kintern (format-string &rest format-args)
185 "Interns a new symbol in the keyword package."
186 (declare (dynamic-extent format-args))
187 (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
189 (defun keywordify (x)
190 "Given a symbol designator 'x', return a keyword whose name is 'x'.
191 If 'x' is nil, this returns nil."
192 (check-type x (or string symbol null))
195 ((symbolp x) (keywordify (symbol-name x)))
196 ((zerop (length x)) nil)
197 ((string-not-equal x "nil")
198 (intern (string-upcase x) (find-package "KEYWORD")))
204 (defmacro with-collectors ((&rest collection-descriptions) &body body)
205 "'collection-descriptions' is a list of clauses of the form (coll function).
206 The body can call each 'function' to add a value to 'coll'. 'function'
207 runs in constant time, regardless of the length of the list."
208 (let ((let-bindings ())
212 (dolist (description collection-descriptions)
213 (destructuring-bind (place name) description
214 (let ((vtail (make-symbol (format nil "~A-TAIL" place))))
215 (setq dynamic-extents
216 (nconc dynamic-extents `(#',name)))
224 (setq ,vtail (if ,vtail
225 (setf (cdr ,vtail) (list ,vobj))
226 (setf ,place (list ,vobj)))))))))))
227 `(let (,@let-bindings)
228 (flet (,@flet-bindings)
229 ,@(and dynamic-extents
230 `((declare (dynamic-extent ,@dynamic-extents))))
233 (defmacro with-prefixed-accessors (names (prefix object) &body body)
234 `(with-accessors (,@(loop for name in names
235 collect `(,name ,(fintern "~A~A" prefix name))))
239 (defmacro dovector ((var vector &optional value) &body body)
240 "Like 'dolist', but iterates over the vector 'vector'."
241 (with-gensyms (vidx vlen vvec)
242 `(let* ((,vvec ,vector)
243 (,vlen (length ,vvec)))
244 (loop for ,vidx fixnum from 0 below ,vlen
245 as ,var = (aref ,vvec ,vidx)
247 finally (return ,value)))))
249 (defmacro doseq ((var sequence &optional value) &body body)
250 "Iterates over a sequence, using 'dolist' or 'dovector' depending on
251 the type of the sequence. In optimized code, this turns out to be
252 faster than (map () #'f sequence).
253 Note that the body gets expanded twice!"
255 `(let ((,vseq ,sequence))
257 (dovector (,var ,vseq ,value)
259 (dolist (,var ,vseq ,value)
263 (defmacro appendf (place tail)
264 "Append 'tail' to the list given by 'place', then set the place to the new list."
265 `(setf ,place (append ,place ,tail)))
268 ;;; Functional programming, please
270 (defun curry (function &rest args)
271 "Returns a function that applies 'function' to 'args', plus any
272 additional arguments given at the call site."
273 (if (and args (null (cdr args))) ;fast test for length = 1
274 (let ((arg (car args)))
275 #'(lambda (&rest more-args)
276 (apply function arg more-args)))
277 #'(lambda (&rest more-args)
278 (apply function (append args more-args)))))
280 (define-compiler-macro curry (&whole form function &rest args &environment env)
281 (declare (ignore env))
282 (if (and (listp function)
283 (eq (first function) 'function)
284 (symbolp (second function))
285 (and args (null (cdr args))))
286 `#'(lambda (&rest more-args)
287 (apply ,function ,(car args) more-args))
293 ;; A parameterized list type for repeated fields
294 ;; The elements aren't type-checked
295 (deftype list-of (type)
296 (if (eq type 'nil) ;a list that cannot have any element (element-type nil) is null
300 ;; The same, but use a (stretchy) vector
301 (deftype vector-of (type)
302 (if (eq type 'nil) ;an array that cannot have any element (element-type nil) is of size 0
304 '(array * (*)))) ;a 1-dimensional array of any type
306 ;; This corresponds to the :bytes Protobufs type
307 (deftype byte-vector () '(array (unsigned-byte 8) (*)))
309 (defun make-byte-vector (size)
310 (make-array size :element-type '(unsigned-byte 8)))
312 ;; The Protobufs integer types
313 (deftype int32 () '(signed-byte 32))
314 (deftype int64 () '(signed-byte 64))
315 (deftype uint32 () '(unsigned-byte 32))
316 (deftype uint64 () '(unsigned-byte 64))
317 (deftype sint32 () '(signed-byte 32))
318 (deftype sint64 () '(signed-byte 64))
319 (deftype fixed32 () '(signed-byte 32))
320 (deftype fixed64 () '(signed-byte 64))
321 (deftype sfixed32 () '(signed-byte 32))
322 (deftype sfixed64 () '(signed-byte 64))
325 (defun type-expand (type)
326 #+(or abcl xcl) (system::expand-deftype type)
327 #+allegro (excl:normalize-type type :default type)
328 #+ccl (ccl::type-expand type)
329 #+clisp (ext:type-expand type)
330 #+cmu (kernel:type-expand type)
331 #+(or ecl mkcl) (si::expand-deftype type)
332 #+lispworks (type:expand-user-type type)
333 #+sbcl (sb-ext:typexpand type)
334 #-(or abcl allegro ccl clisp cmu ecl lispworks mkcl sbcl xcl) type)
337 ;;; Code generation utilities
339 (defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
340 (defparameter *camel-case-field-names* nil)
342 (defun find-proto-package (name)
343 "A very fuzzy definition of 'find-package'."
346 ;; Try looking under the given name and the all-uppercase name
347 (or (find-package (string name))
348 (find-package (string-upcase (string name)))))
350 ;; If 'name' is a list, it's actually a fully-qualified path
351 (or (find-proto-package (first name))
352 (find-proto-package (format nil "~{~A~^.~}" name))))))
354 ;; "class-name" -> "ClassName", ("ClassName")
355 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
356 (defun class-name->proto (x)
357 "Given a Lisp class name, returns a Protobufs message or enum name.
358 The second value is the fully qualified name, as a list."
359 (let* ((xs (split-string (string x) :separators '(#\.)))
360 (ns (loop for x in (butlast xs)
361 collect (remove-if-not #'alphanumericp
362 (camel-case (format nil "~A" x) *proto-name-separators*))))
364 (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
365 (values name (append ns (list name))
366 ;; This might be the name of a package, too
367 (format nil "~{~A~^.~}" (butlast xs)))))
369 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
370 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
371 (defun enum-name->proto (x &optional prefix)
372 "Given a Lisp enum value name, returns a Protobufs enum value name.
373 The second value is the fully qualified name, as a list."
374 (let* ((xs (split-string (string x) :separators '(#\.)))
375 (ns (loop for x in (butlast xs)
376 collect (remove-if-not #'alphanumericp
377 (camel-case (format nil "~A" x) *proto-name-separators*))))
378 (nx (string-upcase (car (last xs))))
379 (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
380 ;; Keep underscores, they are standards separators in Protobufs enum names
381 (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
382 (format nil "~{~A~^_~}"
383 (split-string nx :separators *proto-name-separators*)))))
384 (values name (append ns (list name))
385 (format nil "~{~A~^.~}" (butlast xs)))))
387 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
388 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
389 (defun slot-name->proto (x)
390 "Given a Lisp slot name, returns a Protobufs field name.
391 The second value is the fully qualified name, as a list."
392 (let* ((xs (split-string (string x) :separators '(#\.)))
393 (ns (loop for x in (butlast xs)
394 collect (remove-if-not #'alphanumericp
395 (camel-case (format nil "~A" x) *proto-name-separators*))))
396 (nx (string-downcase (car (last xs))))
397 (name (if *camel-case-field-names*
398 (remove-if-not #'alphanumericp
399 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
400 ;; Keep underscores, they are standards separators in Protobufs field names
401 (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
402 (format nil "~{~A~^_~}"
403 (split-string nx :separators *proto-name-separators*))))))
404 (values name (append ns (list name))
405 (format nil "~{~A~^.~}" (butlast xs)))))
408 ;; "ClassName" -> 'class-name
409 ;; "cl-user.ClassName" -> 'cl-user::class-name
410 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
411 (defun proto->class-name (x &optional package)
412 "Given a Protobufs message or enum type name, returns a Lisp class or type name.
413 This resolves Protobufs qualified names as best as it can."
414 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
416 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
417 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
418 (package (or pkg1 pkgn package))
419 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
420 (values (if package (intern name package) (make-symbol name)) package xs
421 ;; This might be the name of a package, too
422 (format nil "~{~A~^.~}" (butlast xs)))))
424 ;; "ENUM_VALUE" -> :enum-value
425 ;; "cl-user.ENUM_VALUE" -> :enum-value
426 ;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
427 (defun proto->enum-name (x &optional package)
428 "Given a Protobufs enum value name, returns a Lisp enum value name.
429 This resolves Protobufs qualified names as best as it can."
430 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
432 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
433 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
434 (package (or pkg1 pkgn package))
435 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
436 (values (kintern name) package xs
437 (format nil "~{~A~^.~}" (butlast xs)))))
439 ;; "slot_name" or "slotName" -> 'slot-name
440 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
441 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
442 (defun proto->slot-name (x &optional package)
443 "Given a Protobufs field value name, returns a Lisp slot name.
444 This resolves Protobufs qualified names as best as it can."
445 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
447 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
448 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
449 (package (or pkg1 pkgn package))
450 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
451 (values (if package (intern name package) (make-symbol name)) package xs
452 (format nil "~{~A~^.~}" (butlast xs)))))
457 (define-condition protobufs-warning (warning simple-condition) ())
459 (defun protobufs-warn (format-control &rest format-arguments)
460 (warn 'protobufs-warning
461 :format-control format-control
462 :format-arguments format-arguments))
465 #-(or allegro lispworks)
466 (defmacro without-redefinition-warnings (() &body body)
470 (defmacro without-redefinition-warnings (() &body body)
471 `(excl:without-redefinition-warnings ,@body))
474 (defmacro without-redefinition-warnings (() &body body)
475 `(let ((dspec:*redefinition-action* :quiet)) ,@body))
478 ;;; Portable floating point utilities
480 #+(or abcl allegro ccl cmu sbcl lispworks)
481 (defun single-float-bits (x)
482 (declare (type single-float x))
483 #+abcl (system:single-float-bits x)
484 #+allegro (multiple-value-bind (high low)
485 (excl:single-float-to-shorts x)
486 (declare (type (unsigned-byte 16) high low))
487 (logior (ash high 16) low))
488 #+ccl (ccl::single-float-bits x)
489 #+cmu (kernel:single-float-bits x)
490 #+sbcl (sb-kernel:single-float-bits x)
491 #+lispworks (lispworks-float:single-float-bits x))
493 #-(or abcl allegro ccl cmu sbcl lispworks)
494 (defun single-float-bits (x)
495 (declare (type single-float x))
496 (assert (= (float-radix x) 2))
498 (if (eql x 0.0f0) 0 #x-80000000)
499 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
500 (integer-decode-float x)
501 (assert (plusp lisp-significand))
502 (let* ((significand lisp-significand)
503 (exponent (+ lisp-exponent 23 127))
505 (if (plusp exponent) ;if not obviously denormalized
508 ;; Special termination case for denormalized float number
510 ;; Denormalized numbers have exponent one greater than
511 ;; in the exponent field
512 (return (ash significand -1)))
513 ;; Ordinary termination case
514 ((>= significand (expt 2 23))
515 (assert (< 0 significand (expt 2 24)))
516 ;; Exponent 0 is reserved for denormalized numbers,
517 ;; and 255 is reserved for specials like NaN
518 (assert (< 0 exponent 255))
519 (return (logior (ash exponent 23)
520 (logand significand (1- (ash 1 23))))))
522 ;; Shift as necessary to set bit 24 of significand
523 (setq significand (ash significand 1)
524 exponent (1- exponent)))))
525 (do () ((zerop exponent)
526 ;; Denormalized numbers have exponent one greater than
527 ;; the exponent field
528 (ash significand -1))
529 (unless (zerop (logand significand 1))
530 (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
531 (setq significand (ash significand -1)
532 exponent (1+ exponent))))))
534 ((1) unsigned-result)
535 ((-1) (logior unsigned-result (- (expt 2 31)))))))))
538 #+(or abcl allegro ccl cmu sbcl lispworks)
539 (defun double-float-bits (x)
540 (declare (type double-float x))
541 #+abcl (values (system:double-float-low-bits x)
542 (system:double-float-high-bits x))
543 #+allegro (multiple-value-bind (us3 us2 us1 us0)
544 (excl:double-float-to-shorts x)
545 (logior (ash us1 16) us0)
546 (logior (ash us3 16) us2))
547 #+ccl (multiple-value-bind (high low)
548 (ccl::double-float-bits x)
550 #+cmu (values (kernel:double-float-low-bits x)
551 (kernel:double-float-high-bits x))
552 #+sbcl (values (sb-kernel:double-float-low-bits x)
553 (sb-kernel:double-float-high-bits x))
554 #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
555 (values (logand #xffffffff bits)
558 #-(or abcl allegro ccl cmu sbcl lispworks)
559 (defun double-float-bits (x)
560 (declare (type double-float x))
561 (assert (= (float-radix x) 2))
563 (if (eql x 0.0d0) 0 #x-8000000000000000)
564 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
565 (integer-decode-float x)
566 (assert (plusp lisp-significand))
567 (let* ((significand lisp-significand)
568 (exponent (+ lisp-exponent 52 1023))
570 (if (plusp exponent) ;if not obviously denormalized
573 ;; Special termination case for denormalized float number
575 ;; Denormalized numbers have exponent one greater than
576 ;; in the exponent field
577 (return (ash significand -1)))
578 ;; Ordinary termination case
579 ((>= significand (expt 2 52))
580 (assert (< 0 significand (expt 2 53)))
581 ;; Exponent 0 is reserved for denormalized numbers,
582 ;; and 2047 is reserved for specials like NaN
583 (assert (< 0 exponent 2047))
584 (return (logior (ash exponent 52)
585 (logand significand (1- (ash 1 52))))))
587 ;; Shift as necessary to set bit 53 of significand
588 (setq significand (ash significand 1)
589 exponent (1- exponent)))))
590 (do () ((zerop exponent)
591 ;; Denormalized numbers have exponent one greater than
592 ;; the exponent field
593 (ash significand -1))
594 (unless (zerop (logand significand 1))
595 (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
596 (setq significand (ash significand -1)
597 exponent (1+ exponent))))))
600 ((1) unsigned-result)
601 ((-1) (logior unsigned-result (- (expt 2 63)))))))
602 ;; Return the low bits and the high bits
603 (values (logand #xffffffff result) (ash result -32)))))))
606 #+(or abcl allegro ccl cmu sbcl lispworks)
607 (defun make-single-float (bits)
608 (declare (type (signed-byte 32) bits))
609 #+abcl (system:make-single-float bits)
610 #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
611 (ldb (byte 16 0) bits))
612 #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits)
613 #+cmu (kernel:make-single-float bits)
614 #+sbcl (sb-kernel:make-single-float bits)
615 #+lispworks (lispworks-float:make-single-float bits))
617 #-(or abcl allegro ccl cmu sbcl lispworks)
618 (defun make-single-float (bits)
619 (declare (type (signed-byte 32) bits))
621 ;; IEEE float special cases
623 ((= bits #x-80000000) -0.0)
625 (let* ((sign (ecase (ldb (byte 1 31) bits)
628 (iexpt (ldb (byte 8 23) bits))
629 (exponent (if (zerop iexpt) ;denormalized
632 (mantissa (* (logior (ldb (byte 23 0) bits)
633 (if (zerop iexpt) 0 (ash 1 23)))
635 (* sign (expt 2.0 exponent) mantissa)))))
638 #+(or abcl allegro ccl cmu sbcl lispworks)
639 (defun make-double-float (low high)
640 (declare (type (unsigned-byte 32) low)
641 (type (signed-byte 32) high))
642 #+abcl (system:make-double-float (logior (ash high 32) low))
643 #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
644 (ldb (byte 16 0) high)
645 (ldb (byte 16 16) low)
646 (ldb (byte 16 0) low))
647 #+ccl (ccl::double-float-from-bits (logand high #xffffffff) low)
648 #+cmu (kernel:make-double-float high low)
649 #+sbcl (sb-kernel:make-double-float high low)
650 #+lispworks (lispworks-float:make-double-float high low))
652 #-(or abcl allegro ccl cmu sbcl lispworks)
653 (defun make-double-float (low high)
654 (declare (type (unsigned-byte 32) low)
655 (type (signed-byte 32) high))
657 ;; IEEE float special cases
658 ((and (zerop high) (zerop low)) 0.0d0)
659 ((and (= high #x-80000000)
662 (let* ((bits (logior (ash high 32) low))
663 (sign (ecase (ldb (byte 1 63) bits)
666 (iexpt (ldb (byte 11 52) bits))
667 (exponent (if (zerop iexpt) ;denormalized
670 (mantissa (* (logior (ldb (byte 52 0) bits)
671 (if (zerop iexpt) 0 (ash 1 52)))
673 (* sign (expt 2.0d0 exponent) mantissa)))))