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