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 #+(or abcl xcl) (system::expand-deftype type)
325 #+allegro (excl:normalize-type type :default type)
326 #+ccl (ccl::type-expand type)
327 #+clisp (ext:type-expand type)
328 #+cmu (kernel:type-expand type)
329 #+(or ecl mkcl) (si::expand-deftype type)
330 #+lispworks (type:expand-user-type type)
331 #+sbcl (sb-ext:typexpand type)
332 #-(or abcl allegro ccl clisp cmu ecl lispworks mkcl sbcl xcl) type)
335 ;;; Code generation utilities
337 (defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
338 (defparameter *camel-case-field-names* nil)
340 (defun find-proto-package (name)
341 "A very fuzzy definition of 'find-package'."
344 ;; Try looking under the given name and the all-uppercase name
345 (or (find-package (string name))
346 (find-package (string-upcase (string name)))))
348 ;; If 'name' is a list, it's actually a fully-qualified path
349 (or (find-proto-package (first name))
350 (find-proto-package (format nil "~{~A~^.~}" name))))))
352 ;; "class-name" -> "ClassName", ("ClassName")
353 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
354 (defun class-name->proto (x)
355 "Given a Lisp class name, returns a Protobufs message or enum name.
356 The second value is the fully qualified name, as a list."
357 (let* ((xs (split-string (string x) :separators '(#\.)))
358 (ns (loop for x in (butlast xs)
359 collect (remove-if-not #'alphanumericp
360 (camel-case (format nil "~A" x) *proto-name-separators*))))
362 (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
363 (values name (append ns (list name))
364 ;; This might be the name of a package, too
365 (format nil "~{~A~^.~}" (butlast xs)))))
367 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
368 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
369 (defun enum-name->proto (x &optional prefix)
370 "Given a Lisp enum value name, returns a Protobufs enum value name.
371 The second value is the fully qualified name, as a list."
372 (let* ((xs (split-string (string x) :separators '(#\.)))
373 (ns (loop for x in (butlast xs)
374 collect (remove-if-not #'alphanumericp
375 (camel-case (format nil "~A" x) *proto-name-separators*))))
376 (nx (string-upcase (car (last xs))))
377 (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
378 ;; Keep underscores, they are standards separators in Protobufs enum names
379 (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
380 (format nil "~{~A~^_~}"
381 (split-string nx :separators *proto-name-separators*)))))
382 (values name (append ns (list name))
383 (format nil "~{~A~^.~}" (butlast xs)))))
385 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
386 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
387 (defun slot-name->proto (x)
388 "Given a Lisp slot name, returns a Protobufs field name.
389 The second value is the fully qualified name, as a list."
390 (let* ((xs (split-string (string x) :separators '(#\.)))
391 (ns (loop for x in (butlast xs)
392 collect (remove-if-not #'alphanumericp
393 (camel-case (format nil "~A" x) *proto-name-separators*))))
394 (nx (string-downcase (car (last xs))))
395 (name (if *camel-case-field-names*
396 (remove-if-not #'alphanumericp
397 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
398 ;; Keep underscores, they are standards separators in Protobufs field names
399 (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
400 (format nil "~{~A~^_~}"
401 (split-string nx :separators *proto-name-separators*))))))
402 (values name (append ns (list name))
403 (format nil "~{~A~^.~}" (butlast xs)))))
406 ;; "ClassName" -> 'class-name
407 ;; "cl-user.ClassName" -> 'cl-user::class-name
408 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
409 (defun proto->class-name (x &optional package)
410 "Given a Protobufs message or enum type name, returns a Lisp class or type name.
411 This resolves Protobufs qualified names as best as it can."
412 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
414 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
415 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
416 (package (or pkg1 pkgn package))
417 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
418 (values (if package (intern name package) (make-symbol name)) package xs
419 ;; This might be the name of a package, too
420 (format nil "~{~A~^.~}" (butlast xs)))))
422 ;; "ENUM_VALUE" -> :enum-value
423 ;; "cl-user.ENUM_VALUE" -> :enum-value
424 ;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
425 (defun proto->enum-name (x &optional package)
426 "Given a Protobufs enum value name, returns a Lisp enum value name.
427 This resolves Protobufs qualified names as best as it can."
428 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
430 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
431 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
432 (package (or pkg1 pkgn package))
433 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
434 (values (kintern name) package xs
435 (format nil "~{~A~^.~}" (butlast xs)))))
437 ;; "slot_name" or "slotName" -> 'slot-name
438 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
439 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
440 (defun proto->slot-name (x &optional package)
441 "Given a Protobufs field value name, returns a Lisp slot name.
442 This resolves Protobufs qualified names as best as it can."
443 (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
445 (pkg1 (and (cdr xs) (find-proto-package (first xs))))
446 (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
447 (package (or pkg1 pkgn package))
448 (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
449 (values (if package (intern name package) (make-symbol name)) package xs
450 (format nil "~{~A~^.~}" (butlast xs)))))
455 (define-condition protobufs-warning (warning simple-condition) ())
457 (defun protobufs-warn (format-control &rest format-arguments)
458 (warn 'protobufs-warning
459 :format-control format-control
460 :format-arguments format-arguments))
463 #-(or allegro lispworks)
464 (defmacro without-redefinition-warnings (() &body body)
468 (defmacro without-redefinition-warnings (() &body body)
469 `(excl:without-redefinition-warnings ,@body))
472 (defmacro without-redefinition-warnings (() &body body)
473 `(let ((dspec:*redefinition-action* :quiet)) ,@body))
476 ;;; Portable floating point utilities
478 #+(or abcl allegro ccl cmu sbcl lispworks)
479 (defun single-float-bits (x)
480 (declare (type single-float x))
481 #+abcl (system:single-float-bits x)
482 #+allegro (multiple-value-bind (high low)
483 (excl:single-float-to-shorts x)
484 (declare (type (unsigned-byte 16) high low))
485 (logior (ash high 16) low))
486 #+ccl (ccl::single-float-bits x)
487 #+cmu (kernel:single-float-bits x)
488 #+sbcl (sb-kernel:single-float-bits x)
489 #+lispworks (lispworks-float:single-float-bits x))
491 #-(or abcl allegro ccl cmu sbcl lispworks)
492 (defun single-float-bits (x)
493 (declare (type single-float x))
494 (assert (= (float-radix x) 2))
496 (if (eql x 0.0f0) 0 #x-80000000)
497 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
498 (integer-decode-float x)
499 (assert (plusp lisp-significand))
500 (let* ((significand lisp-significand)
501 (exponent (+ lisp-exponent 23 127))
503 (if (plusp exponent) ;if not obviously denormalized
506 ;; Special termination case for denormalized float number
508 ;; Denormalized numbers have exponent one greater than
509 ;; in the exponent field
510 (return (ash significand -1)))
511 ;; Ordinary termination case
512 ((>= significand (expt 2 23))
513 (assert (< 0 significand (expt 2 24)))
514 ;; Exponent 0 is reserved for denormalized numbers,
515 ;; and 255 is reserved for specials like NaN
516 (assert (< 0 exponent 255))
517 (return (logior (ash exponent 23)
518 (logand significand (1- (ash 1 23))))))
520 ;; Shift as necessary to set bit 24 of significand
521 (setq significand (ash significand 1)
522 exponent (1- exponent)))))
523 (do () ((zerop exponent)
524 ;; Denormalized numbers have exponent one greater than
525 ;; the exponent field
526 (ash significand -1))
527 (unless (zerop (logand significand 1))
528 (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
529 (setq significand (ash significand -1)
530 exponent (1+ exponent))))))
532 ((1) unsigned-result)
533 ((-1) (logior unsigned-result (- (expt 2 31)))))))))
536 #+(or abcl allegro ccl cmu sbcl lispworks)
537 (defun double-float-bits (x)
538 (declare (type double-float x))
539 #+abcl (values (system:double-float-low-bits x)
540 (system:double-float-high-bits x))
541 #+allegro (multiple-value-bind (us3 us2 us1 us0)
542 (excl:double-float-to-shorts x)
543 (logior (ash us1 16) us0)
544 (logior (ash us3 16) us2))
545 #+ccl (multiple-value-bind (high low)
546 (ccl::double-float-bits x)
548 #+cmu (values (kernel:double-float-low-bits x)
549 (kernel:double-float-high-bits x))
550 #+sbcl (values (sb-kernel:double-float-low-bits x)
551 (sb-kernel:double-float-high-bits x))
552 #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
553 (values (logand #xffffffff bits)
556 #-(or abcl allegro ccl cmu sbcl lispworks)
557 (defun double-float-bits (x)
558 (declare (type double-float x))
559 (assert (= (float-radix x) 2))
561 (if (eql x 0.0d0) 0 #x-8000000000000000)
562 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
563 (integer-decode-float x)
564 (assert (plusp lisp-significand))
565 (let* ((significand lisp-significand)
566 (exponent (+ lisp-exponent 52 1023))
568 (if (plusp exponent) ;if not obviously denormalized
571 ;; Special termination case for denormalized float number
573 ;; Denormalized numbers have exponent one greater than
574 ;; in the exponent field
575 (return (ash significand -1)))
576 ;; Ordinary termination case
577 ((>= significand (expt 2 52))
578 (assert (< 0 significand (expt 2 53)))
579 ;; Exponent 0 is reserved for denormalized numbers,
580 ;; and 2047 is reserved for specials like NaN
581 (assert (< 0 exponent 2047))
582 (return (logior (ash exponent 52)
583 (logand significand (1- (ash 1 52))))))
585 ;; Shift as necessary to set bit 53 of significand
586 (setq significand (ash significand 1)
587 exponent (1- exponent)))))
588 (do () ((zerop exponent)
589 ;; Denormalized numbers have exponent one greater than
590 ;; the exponent field
591 (ash significand -1))
592 (unless (zerop (logand significand 1))
593 (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
594 (setq significand (ash significand -1)
595 exponent (1+ exponent))))))
598 ((1) unsigned-result)
599 ((-1) (logior unsigned-result (- (expt 2 63)))))))
600 ;; Return the low bits and the high bits
601 (values (logand #xffffffff result) (ash result -32)))))))
604 #+(or abcl allegro ccl cmu sbcl lispworks)
605 (defun make-single-float (bits)
606 (declare (type (signed-byte 32) bits))
607 #+abcl (system:make-single-float bits)
608 #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
609 (ldb (byte 16 0) bits))
610 #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits)
611 #+cmu (kernel:make-single-float bits)
612 #+sbcl (sb-kernel:make-single-float bits)
613 #+lispworks (lispworks-float:make-single-float bits))
615 #-(or abcl allegro ccl cmu sbcl lispworks)
616 (defun make-single-float (bits)
617 (declare (type (signed-byte 32) bits))
619 ;; IEEE float special cases
621 ((= bits #x-80000000) -0.0)
623 (let* ((sign (ecase (ldb (byte 1 31) bits)
626 (iexpt (ldb (byte 8 23) bits))
627 (exponent (if (zerop iexpt) ;denormalized
630 (mantissa (* (logior (ldb (byte 23 0) bits)
631 (if (zerop iexpt) 0 (ash 1 23)))
633 (* sign (expt 2.0 exponent) mantissa)))))
636 #+(or abcl allegro ccl cmu sbcl lispworks)
637 (defun make-double-float (low high)
638 (declare (type (unsigned-byte 32) low)
639 (type (signed-byte 32) high))
640 #+abcl (system:make-double-float (logior (ash high 32) low))
641 #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
642 (ldb (byte 16 0) high)
643 (ldb (byte 16 16) low)
644 (ldb (byte 16 0) low))
645 #+ccl (ccl::double-float-from-bits (logand high #xffffffff) low)
646 #+cmu (kernel:make-double-float high low)
647 #+sbcl (sb-kernel:make-double-float high low)
648 #+lispworks (lispworks-float:make-double-float high low))
650 #-(or abcl allegro ccl cmu sbcl lispworks)
651 (defun make-double-float (low high)
652 (declare (type (unsigned-byte 32) low)
653 (type (signed-byte 32) high))
655 ;; IEEE float special cases
656 ((and (zerop high) (zerop low)) 0.0d0)
657 ((and (= high #x-80000000)
660 (let* ((bits (logior (ash high 32) low))
661 (sign (ecase (ldb (byte 1 63) bits)
664 (iexpt (ldb (byte 11 52) bits))
665 (exponent (if (zerop iexpt) ;denormalized
668 (mantissa (* (logior (ldb (byte 52 0) bits)
669 (if (zerop iexpt) 0 (ash 1 52)))
671 (* sign (expt 2.0d0 exponent) mantissa)))))