utilities.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Optimized fixnum arithmetic
  15
  16 (defconstant $optimize-default     '(optimize (speed 1) (safety 3) (debug 3))
  17   "Compiler optimization settings for safe, debuggable code.")
  18
  19 (defconstant $optimize-fast-unsafe '(optimize (speed 3) (safety 0) (debug 0))
  20   "Compiler optimization settings for fast, unsafe, hard-to-debug code.")
  21
  22
  23 (defmacro i+ (&rest fixnums)
  24   `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
  25
  26 (defmacro i- (number &rest fixnums)
  27   `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
  28
  29 (defmacro i* (&rest fixnums)
  30   `(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n)))))
  31
  32 (defmacro i= (&rest fixnums)
  33   `(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
  34
  35 (defmacro i< (&rest fixnums)
  36   `(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
  37
  38 (defmacro i<= (&rest fixnums)
  39   `(<= ,@(loop for n in fixnums collect `(the fixnum ,n))))
  40
  41 (defmacro i> (&rest fixnums)
  42   `(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
  43
  44 (defmacro i>= (&rest fixnums)
  45   `(>= ,@(loop for n in fixnums collect `(the fixnum ,n))))
  46
  47 (defmacro iash (value count)
  48   `(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
  49
  50 (defmacro ilogior (&rest fixnums)
  51   (if (cdr fixnums)
  52     `(the fixnum (logior (the fixnum ,(car fixnums))
  53                          ,(if (cddr fixnums)
  54                             `(ilogior ,@(cdr fixnums))
  55                             `(the fixnum ,(cadr fixnums)))))
  56     `(the fixnum ,(car fixnums))))
  57
  58 (defmacro ilogand (&rest fixnums)
  59   (if (cdr fixnums)
  60     `(the fixnum (logand (the fixnum ,(car fixnums))
  61                          ,(if (cddr fixnums)
  62                             `(ilogand ,@(cdr fixnums))
  63                             `(the fixnum ,(cadr fixnums)))))
  64     `(the fixnum ,(car fixnums))))
  65
  66 (define-modify-macro iincf (&optional (delta 1)) i+)
  67 (define-modify-macro idecf (&optional (delta 1)) i-)
  68
  69 (defmacro ildb (bytespec value)
  70   `(the fixnum (ldb ,bytespec (the fixnum ,value))))
  71
  72
  73 ;;; String utilities
  74
  75 (defun starts-with (string prefix &key (start 0))
  76   "Returns true if 'string' starts with the prefix 'prefix' (case insensitive)."
  77   (and (i>= (length string) (i+ start (length prefix)))
  78        (string-equal string prefix :start1 start :end1 (i+ start (length prefix)))
  79        prefix))
  80
  81 (defun ends-with (string suffix &key (end (length string)))
  82   "Returns true if 'string' ends with the prefix 'prefix' (case insensitive)."
  83   (and (i>= end (length suffix))
  84        (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
  85        suffix))
  86
  87
  88 ;; (camel-case "camel-case") => "CamelCase"
  89 (defun camel-case (string &optional (separators '(#\-)))
  90   (let ((words (split-string string :separators separators)))
  91     (format nil "~{~@(~A~)~}" words)))
  92
  93 ;; (camel-case-but-one "camel-case") => "camelCase"
  94 (defun camel-case-but-one (string &optional (separators '(#\-)))
  95   (let ((words (split-string string :separators separators)))
  96     (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
  97
  98
  99 ;; (uncamel-case "CamelCase") => "CAMEL-CASE"
 100 ;; (uncamel-case "TCPConnection") => "TCP-CONNECTION"
 101 ;; (uncamel-case "NewTCPConnection") => "NEW-TCP-CONNECTION"
 102 ;; (uncamel-case "new_RPC_LispService") => "NEW-RPC-LISP-SERVICE"
 103 ;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
 104 ;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
 105 (defun uncamel-case (name)
 106   ;; We need a whole state machine to get this right
 107   (labels ((uncamel (chars state result)
 108              (let ((ch (first chars)))
 109                (cond ((null chars)
 110                       result)
 111                      ((upper-case-p ch)
 112                       (uncamel (rest chars) 'upper
 113                                (case state
 114                                  ((upper)
 115                                   ;; "TCPConnection" => "TCP-CONNECTION"
 116                                   (if (and (second chars) (lower-case-p (second chars)))
 117                                     (list* ch #\- result)
 118                                     (cons ch result)))
 119                                  ((lower digit) (list* ch #\- result))
 120                                  (otherwise (cons ch result)))))
 121                      ((lower-case-p ch)
 122                       (uncamel (rest chars) 'lower
 123                                (cons (char-upcase ch) result)))
 124                      ((digit-char-p ch)
 125                       (uncamel (rest chars) 'digit
 126                                (cons ch result)))
 127                      ((eql ch #\_)
 128                       (uncamel (rest chars) '_
 129                                (cons #\- result)))
 130                      (t
 131                       (error "Invalid name character: ~A" ch))))))
 132     (concatenate 'string (nreverse (uncamel (concatenate 'list name) nil ())))))
 133
 134
 135 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
 136   "Given a string 'string', splits it at each of the separators.
 137    Returns a list of the string pieces, with empty pieces removed."
 138   (unless (i= start end)
 139     (loop for this fixnum = start then (i+ next 1)
 140           for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
 141                                              :start this :end end)
 142                                 end)
 143           for piece = (string-right-trim '(#\space) (subseq line this next))
 144           when (not (i= (length piece) 0))
 145             collect piece
 146           until (i>= next end))))
 147
 148
 149 ;;; Managing symbols
 150
 151 (defmacro with-gensyms ((&rest bindings) &body body)
 152   `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
 153      ,@body))
 154
 155 (defun make-lisp-symbol (string)
 156   "Intern a string of the 'package:string' and return the symbol."
 157   (let* ((string (string string))
 158          (colon  (position #\: string))
 159          (pkg    (if colon (subseq string 0 colon) "KEYWORD"))
 160          (sym    (if colon (subseq string (+ colon 1)) string)))
 161     (intern sym pkg)))
 162
 163 (defun fintern (format-string &rest format-args)
 164   "Interns a new symbol in the current package."
 165   (declare (dynamic-extent format-args))
 166   (intern (nstring-upcase (apply #'format nil format-string format-args))))
 167
 168 (defun kintern (format-string &rest format-args)
 169   "Interns a new symbol in the keyword package."
 170   (declare (dynamic-extent format-args))
 171   (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
 172
 173 (defun keywordify (x)
 174   "Given a symbol designator 'x', return a keyword whose name is 'x'.
 175    If 'x' is nil, this returns nil."
 176   (check-type x (or string symbol null))
 177   (cond ((null x) nil)
 178         ((keywordp x) x)
 179         ((symbolp x) (keywordify (symbol-name x)))
 180         ((zerop (length x)) nil)
 181         ((string-not-equal x "nil")
 182          (intern (string-upcase x) (find-package "KEYWORD")))
 183         (t nil)))
 184
 185 ;;; Collectors, etc
 186
 187 (defmacro with-collectors ((&rest collection-descriptions) &body body)
 188   (let ((let-bindings  ())
 189         (flet-bindings ())
 190         (dynamic-extents ())
 191         (vobj '#:OBJECT))
 192     (dolist (description collection-descriptions)
 193       (destructuring-bind (place name) description
 194         (let ((vtail (make-symbol (format nil "~A-TAIL" place))))
 195           (setq dynamic-extents
 196                 (nconc dynamic-extents `(#',name)))
 197           (setq let-bindings
 198                 (nconc let-bindings
 199                        `((,place ())
 200                          (,vtail nil))))
 201           (setq flet-bindings
 202                 (nconc flet-bindings
 203                        `((,name (,vobj)
 204                            (setq ,vtail (if ,vtail
 205                                           (setf (cdr ,vtail)  (list ,vobj))
 206                                           (setf ,place (list ,vobj)))))))))))
 207     `(let (,@let-bindings)
 208        (flet (,@flet-bindings)
 209          ,@(and dynamic-extents
 210                 `((declare (dynamic-extent ,@dynamic-extents))))
 211          ,@body))))
 212
 213 (defmacro with-prefixed-accessors (names (prefix object) &body body)
 214   `(with-accessors (,@(loop for name in names
 215                             collect `(,name ,(fintern "~A~A" prefix name))))
 216        ,object
 217      ,@body))
 218
 219 (defmacro dovector ((var vector &optional value) &body body)
 220   (with-gensyms (vidx vlen vvec)
 221     `(let* ((,vvec ,vector)
 222             (,vlen (length ,vvec)))
 223        (loop for ,vidx fixnum from 0 below ,vlen
 224              as ,var = (aref ,vvec ,vidx)
 225              do (progn ,@body)
 226              finally (return ,value)))))
 227
 228
 229 ;;; Functional programming, please
 230
 231 (defun curry (function &rest args)
 232   (if (and args (null (cdr args)))                      ;fast test for length = 1
 233     (let ((arg (car args)))
 234       #'(lambda (&rest more-args)
 235           (apply function arg more-args)))
 236     #'(lambda (&rest more-args)
 237         (apply function (append args more-args)))))
 238
 239 (define-compiler-macro curry (&whole form function &rest args &environment env)
 240   (declare (ignore env))
 241   (if (and (listp function)
 242            (eq (first function) 'function)
 243            (symbolp (second function))
 244            (and args (null (cdr args))))
 245     `#'(lambda (&rest more-args)
 246          (apply ,function ,(car args) more-args))
 247     form))
 248
 249
 250 ;; A parameterized list type for repeated fields
 251 ;; The elements aren't type-checked
 252 (deftype list-of (type)
 253   (if (eq type 'null)
 254     'null
 255     'list))
 256
 257 ;; The same, but use a (stretchy) vector
 258 (deftype vector-of (type)
 259   (if (eq type 'null)
 260     'null
 261     '(array *)))
 262
 263 ;; This corresponds to the :bytes Protobufs type
 264 (deftype byte-vector () '(array (unsigned-byte 8)))
 265
 266 (defun make-byte-vector (size)
 267   (make-array size :element-type '(unsigned-byte 8)))
 268
 269 ;; The Protobufs integer types
 270 (deftype    int32 () '(signed-byte 32))
 271 (deftype    int64 () '(signed-byte 64))
 272 (deftype   uint32 () '(unsigned-byte 32))
 273 (deftype   uint64 () '(unsigned-byte 64))
 274 (deftype   sint32 () '(signed-byte 32))
 275 (deftype   sint64 () '(signed-byte 64))
 276 (deftype  fixed32 () '(signed-byte 32))
 277 (deftype  fixed64 () '(signed-byte 64))
 278 (deftype sfixed32 () '(signed-byte 32))
 279 (deftype sfixed64 () '(signed-byte 64))
 280
 281
 282 ;;; Code generation utilities
 283
 284 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
 285 (defvar *camel-case-field-names* nil)
 286
 287 ;; "class-name" -> "ClassName", ("ClassName")
 288 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
 289 (defun class-name->proto (x)
 290   "Given a Lisp class name, returns a Protobufs message or enum name.
 291    The second value is the fully qualified name, as a list."
 292   (let* ((xs (split-string (string x) :separators '(#\.)))
 293          (ns (loop for x in (butlast xs)
 294                    collect (remove-if-not #'alphanumericp
 295                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 296          (nx (car (last xs)))
 297          (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
 298     (values name (append ns (list name)))))
 299
 300 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
 301 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
 302 (defun enum-name->proto (x &optional prefix)
 303   "Given a Lisp enum value name, returns a Protobufs enum value name.
 304    The second value is the fully qualified name, as a list."
 305   (let* ((xs (split-string (string x) :separators '(#\.)))
 306          (ns (loop for x in (butlast xs)
 307                    collect (remove-if-not #'alphanumericp
 308                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 309          (nx (string-upcase (car (last xs))))
 310          (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
 311          ;; Keep underscores, they are standards separators in Protobufs enum names
 312          (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
 313                               (format nil "~{~A~^_~}"
 314                                       (split-string nx :separators *proto-name-separators*)))))
 315     (values name (append ns (list name)))))
 316
 317 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
 318 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
 319 (defun slot-name->proto (x)
 320   "Given a Lisp slot name, returns a Protobufs field name.
 321    The second value is the fully qualified name, as a list."
 322   (let* ((xs (split-string (string x) :separators '(#\.)))
 323          (ns (loop for x in (butlast xs)
 324                    collect (remove-if-not #'alphanumericp
 325                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 326          (nx (string-downcase (car (last xs))))
 327          (name (if *camel-case-field-names*
 328                  (remove-if-not #'alphanumericp
 329                                 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
 330                  ;; Keep underscores, they are standards separators in Protobufs field names
 331                  (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
 332                                 (format nil "~{~A~^_~}"
 333                                         (split-string nx :separators *proto-name-separators*))))))
 334     (values name (append ns (list name)))))
 335
 336
 337 ;; "ClassName" -> 'class-name
 338 ;; "cl-user.ClassName" -> 'cl-user::class-name
 339 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
 340 (defun proto->class-name (x &optional package)
 341   "Given a Protobufs message or enum type name, returns a Lisp class or type name.
 342    This resolves Protobufs qualified names as best as it can."
 343   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
 344                            :separators '(#\.)))
 345          (pkg (and (cdr xs) (find-package (first xs))))
 346          (package (or pkg package))
 347          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 348     (values (if package (intern name package) (make-symbol name)) package xs)))
 349
 350 ;; "ENUM_VALUE" -> :enum-value
 351 ;; "cl-user.ENUM_VALUE" -> :enum-value
 352 ;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
 353 (defun proto->enum-name (x &optional package)
 354   "Given a Protobufs enum value name, returns a Lisp enum value name.
 355    This resolves Protobufs qualified names as best as it can."
 356   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
 357                            :separators '(#\.)))
 358          (pkg (and (cdr xs) (find-package (first xs))))
 359          (package (or pkg package))
 360          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 361     (values (kintern name) package xs)))
 362
 363 ;; "slot_name" or "slotName" -> 'slot-name
 364 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
 365 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
 366 (defun proto->slot-name (x &optional package)
 367   "Given a Protobufs field value name, returns a Lisp slot name.
 368    This resolves Protobufs qualified names as best as it can."
 369   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
 370                            :separators '(#\.)))
 371          (pkg (and (cdr xs) (find-package (first xs))))
 372          (package (or pkg package))
 373          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 374     (values (if package (intern name package) (make-symbol name)) package xs)))
 375
 376
 377 (define-condition protobufs-warning (warning simple-condition) ())
 378
 379 (defun protobufs-warn (format-control &rest format-arguments)
 380   (warn 'protobufs-warning
 381         :format-control format-control
 382         :format-arguments format-arguments))
 383
 384
 385 #-(or allegro lispworks)
 386 (defmacro without-redefinition-warnings (() &body body)
 387   `(progn ,@body))
 388
 389 #+allegro
 390 (defmacro without-redefinition-warnings (() &body body)
 391   `(excl:without-redefinition-warnings ,@body))
 392
 393 #+lispworks
 394 (defmacro without-redefinition-warnings (() &body body)
 395   `(let ((dspec:*redefinition-action* :quiet)) ,@body))
 396
 397 \f
 398 ;;; Floating point utilities
 399
 400 #+(or abcl allegro cmu sbcl lispworks)
 401 (defun single-float-bits (x)
 402   (declare (type single-float x))
 403   #+abcl    (system:single-float-bits x)
 404   #+allegro (multiple-value-bind (high low)
 405                 (excl:single-float-to-shorts x)
 406               (declare (type (unsigned-byte 16) high low))
 407               (logior (ash high 16) low))
 408   #+cmu  (kernel:single-float-bits x)
 409   #+sbcl (sb-kernel:single-float-bits x)
 410   #+lispworks (lispworks-float:single-float-bits x))
 411
 412 #-(or abcl allegro cmu sbcl lispworks)
 413 (defun single-float-bits (x)
 414   (declare (type single-float x))
 415   (assert (= (float-radix x) 2))
 416   (if (zerop x)
 417     (if (eql x 0.0f0) 0 #x-80000000)
 418     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 419         (integer-decode-float x)
 420       (assert (plusp lisp-significand))
 421       (let* ((significand lisp-significand)
 422              (exponent (+ lisp-exponent 23 127))
 423              (unsigned-result
 424               (if (plusp exponent)                      ;if not obviously denormalized
 425                 (do () (nil)
 426                   (cond
 427                     ;; Special termination case for denormalized float number
 428                     ((zerop exponent)
 429                      ;; Denormalized numbers have exponent one greater than
 430                      ;; in the exponent field
 431                      (return (ash significand -1)))
 432                     ;; Ordinary termination case
 433                     ((>= significand (expt 2 23))
 434                      (assert (< 0 significand (expt 2 24)))
 435                      ;; Exponent 0 is reserved for denormalized numbers,
 436                      ;; and 255 is reserved for specials like NaN
 437                      (assert (< 0 exponent 255))
 438                      (return (logior (ash exponent 23)
 439                                      (logand significand (1- (ash 1 23))))))
 440                     (t
 441                      ;; Shift as necessary to set bit 24 of significand
 442                      (setq significand (ash significand 1)
 443                            exponent (1- exponent)))))
 444                 (do () ((zerop exponent)
 445                         ;; Denormalized numbers have exponent one greater than
 446                         ;; the exponent field
 447                         (ash significand -1))
 448                   (unless (zerop (logand significand 1))
 449                     (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
 450                   (setq significand (ash significand -1)
 451                         exponent (1+ exponent))))))
 452         (ecase lisp-sign
 453           ((1)  unsigned-result)
 454           ((-1) (logior unsigned-result (- (expt 2 31)))))))))
 455
 456
 457 #+(or abcl allegro cmu sbcl lispworks)
 458 (defun double-float-bits (x)
 459   (declare (type double-float x))
 460   #+abcl    (values (system:double-float-low-bits x)
 461                     (system:double-float-high-bits x))
 462   #+allegro (multiple-value-bind (us3 us2 us1 us0)
 463                 (excl:double-float-to-shorts x)
 464               (logior (ash us1 16) us0)
 465               (logior (ash us3 16) us2))
 466   #+cmu  (values (kernel:double-float-low-bits x)
 467                  (kernel:double-float-high-bits x))
 468   #+sbcl (values (sb-kernel:double-float-low-bits x)
 469                  (sb-kernel:double-float-high-bits x))
 470   #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
 471                 (values (logand #xffffffff bits)
 472                         (ash bits -32))))
 473
 474 #-(or abcl allegro cmu sbcl lispworks)
 475 (defun double-float-bits (x)
 476   (declare (type double-float x))
 477   (assert (= (float-radix x) 2))
 478   (if (zerop x)
 479     (if (eql x 0.0d0) 0 #x-8000000000000000)
 480     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 481         (integer-decode-float x)
 482       (assert (plusp lisp-significand))
 483       (let* ((significand lisp-significand)
 484              (exponent (+ lisp-exponent 52 1023))
 485              (unsigned-result
 486               (if (plusp exponent)                      ;if not obviously denormalized
 487                 (do () (nil)
 488                   (cond
 489                     ;; Special termination case for denormalized float number
 490                     ((zerop exponent)
 491                      ;; Denormalized numbers have exponent one greater than
 492                      ;; in the exponent field
 493                      (return (ash significand -1)))
 494                     ;; Ordinary termination case
 495                     ((>= significand (expt 2 52))
 496                      (assert (< 0 significand (expt 2 53)))
 497                      ;; Exponent 0 is reserved for denormalized numbers,
 498                      ;; and 2047 is reserved for specials like NaN
 499                      (assert (< 0 exponent 2047))
 500                      (return (logior (ash exponent 52)
 501                                      (logand significand (1- (ash 1 52))))))
 502                     (t
 503                      ;; Shift as necessary to set bit 53 of significand
 504                      (setq significand (ash significand 1)
 505                            exponent (1- exponent)))))
 506                 (do () ((zerop exponent)
 507                         ;; Denormalized numbers have exponent one greater than
 508                         ;; the exponent field
 509                         (ash significand -1))
 510                   (unless (zerop (logand significand 1))
 511                     (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
 512                   (setq significand (ash significand -1)
 513                         exponent (1+ exponent))))))
 514         (let ((result
 515                (ecase lisp-sign
 516                  ((1)  unsigned-result)
 517                  ((-1) (logior unsigned-result (- (expt 2 63)))))))
 518           ;; Return the low bits and the high bits
 519           (values (logand #xffffffff result) (ash result -32)))))))
 520
 521
 522 #+(or abcl allegro cmu sbcl lispworks)
 523 (defun make-single-float (bits)
 524   (declare (type (signed-byte 32) bits))
 525   #+abcl    (system:make-single-float bits)
 526   #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
 527                                          (ldb (byte 16 0) bits))
 528   #+cmu  (kernel:make-single-float bits)
 529   #+sbcl (sb-kernel:make-single-float bits)
 530   #+lispworks (lispworks-float:make-single-float bits))
 531
 532 #-(or abcl allegro cmu sbcl lispworks)
 533 (defun make-single-float (bits)
 534   (declare (type (signed-byte 32) bits))
 535   (cond
 536     ;; IEEE float special cases
 537     ((zerop bits) 0.0)
 538     ((= bits #x-80000000) -0.0)
 539     (t
 540      (let* ((sign (ecase (ldb (byte 1 31) bits)
 541                     (0 1.0)
 542                     (1 -1.0)))
 543             (iexpt (ldb (byte 8 23) bits))
 544             (exponent (if (zerop iexpt)                 ;denormalized
 545                         -126
 546                         (- iexpt 127)))
 547             (mantissa (* (logior (ldb (byte 23 0) bits)
 548                                  (if (zerop iexpt) 0 (ash 1 23)))
 549                          (expt 0.5 23))))
 550        (* sign (expt 2.0 exponent) mantissa)))))
 551
 552
 553 #+(or abcl allegro cmu sbcl lispworks)
 554 (defun make-double-float (low high)
 555   (declare (type (unsigned-byte 32) low)
 556            (type (signed-byte   32) high))
 557   #+abcl (system:make-double-float (logior (ash high 32) low))
 558   #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
 559                                          (ldb (byte 16 0) high)
 560                                          (ldb (byte 16 16) low)
 561                                          (ldb (byte 16 0) low))
 562   #+cmu  (kernel:make-double-float high low)
 563   #+sbcl (sb-kernel:make-double-float high low)
 564   #+lispworks (lispworks-float:make-double-float high low))
 565
 566 #-(or abcl allegro cmu sbcl lispworks)
 567 (defun make-double-float (low high)
 568   (declare (type (unsigned-byte 32) low)
 569            (type (signed-byte   32) high))
 570   (cond
 571     ;; IEEE float special cases
 572     ((and (zerop high) (zerop low)) 0.0d0)
 573     ((and (= high #x-80000000)
 574           (zerop low)) -0.0d0)
 575     (t
 576      (let* ((bits (logior (ash high 32) low))
 577             (sign (ecase (ldb (byte 1 63) bits)
 578                     (0 1.0d0)
 579                     (1 -1.0d0)))
 580             (iexpt (ldb (byte 11 52) bits))
 581             (exponent (if (zerop iexpt)                 ;denormalized
 582                         -1022
 583                         (- iexpt 1023)))
 584             (mantissa (* (logior (ldb (byte 52 0) bits)
 585                                  (if (zerop iexpt) 0 (ash 1 52)))
 586                          (expt 0.5d0 52))))
 587        (* sign (expt 2.0d0 exponent) mantissa)))))