utilities.lisp

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