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 ;;; Utilities
  15
  16 (defun class-name->proto (x)
  17   "Given a Lisp class name, returns a Protobufs message or enum name."
  18   (remove-if-not #'alphanumericp
  19                  (camel-case (format nil "~A" x) :separators '(#\- #\_ #\/))))
  20
  21 (defun enum-name->proto (x &optional prefix)
  22   "Given a Lisp enum value name, returns a Protobufs enum value name."
  23   (let* ((x (string-upcase (string x)))
  24          (x (if (and prefix (starts-with x prefix)) (subseq x (length prefix)) x)))
  25     (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
  26                    (format nil "~{~A~^_~}" (split-string x :separators '(#\- #\_ #\/ #\.))))))
  27
  28 (defun slot-name->proto (x)
  29   "Given a Lisp slot name, returns a Protobufs field name."
  30   (remove-if-not #'alphanumericp
  31                  (camel-case-but-one (format nil "~A" x) :separators '(#\- #\_ #\/ #\.))))
  32
  33
  34 (defun proto->class-name (x &optional package)
  35   "Given a Protobufs message or enum type name, returns a Lisp class or type name."
  36   (let ((name (string-upcase (uncamel-case x))))
  37     (if package (intern name package) (make-symbol name))))
  38
  39 (defun proto->enum-name (x &optional package)
  40   "Given a Protobufs enum value name, returns a Lisp enum value name."
  41   (let ((name (format nil "~{~A~^-~}" (split-string (string-upcase x) :separators '(#\_)))))
  42     (if package (intern name package) (make-symbol name))))
  43
  44 (defun proto->slot-name (x &optional package)
  45   "Given a Protobufs field value name, returns a Lisp slot name."
  46   (let ((name (string-upcase (uncamel-case x))))
  47     (if package (intern name package) (make-symbol name))))
  48
  49
  50 (define-condition protobufs-warning (warning simple-condition) ())
  51
  52 (defun protobufs-warn (format-control &rest format-arguments)
  53   (warn 'protobufs-warning
  54         :format-control format-control
  55         :format-arguments format-arguments))
  56
  57
  58 #-quux
  59 (progn
  60
  61 (defmacro i+ (&rest fixnums)
  62   `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
  63
  64 (defmacro i- (number &rest fixnums)
  65   `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
  66
  67 (defmacro i= (&rest fixnums)
  68   `(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
  69
  70 (defmacro i< (&rest fixnums)
  71   `(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
  72
  73 (defmacro i> (&rest fixnums)
  74   `(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
  75
  76 (defmacro iash (value count)
  77   `(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
  78
  79 (defmacro ilogior (&rest fixnums)
  80   (if (cdr fixnums)
  81     `(the fixnum (logior (the fixnum ,(car fixnums))
  82                          ,(if (cddr fixnums)
  83                             `(ilogior ,@(cdr fixnums))
  84                             `(the fixnum ,(cadr fixnums)))))
  85     `(the fixnum ,(car fixnums))))
  86
  87 (defmacro ilogand (&rest fixnums)
  88   (if (cdr fixnums)
  89     `(the fixnum (logand (the fixnum ,(car fixnums))
  90                          ,(if (cddr fixnums)
  91                             `(ilogand ,@(cdr fixnums))
  92                             `(the fixnum ,(cadr fixnums)))))
  93     `(the fixnum ,(car fixnums))))
  94
  95 (define-modify-macro iincf (&optional (delta 1)) i+)
  96 (define-modify-macro idecf (&optional (delta 1)) i-)
  97
  98 )       ;#-quux
  99
 100 \f
 101 ;;; Floating point utilities
 102
 103 #+(or abcl allegro cmu sbcl lispworks)
 104 (defun single-float-bits (x)
 105   (declare (type single-float x))
 106   #+abcl    (system:single-float-bits float)
 107   #+allegro (multiple-value-bind (high low)
 108                 (excl:single-float-to-shorts float)
 109               (declare (type (unsigned-byte 16) high low))
 110               (logior (ash high 16) low))
 111   #+cmu  (kernel:single-float-bits float)
 112   #+sbcl (sb-kernel:single-float-bits float)
 113   #+lispworks (lispworks-float:single-float-bits float))
 114
 115 #-(or abcl allegro cmu sbcl lispworks)
 116 (defun single-float-bits (x)
 117   (declare (type single-float x))
 118   (assert (= (float-radix x) 2))
 119   (if (zerop x)
 120     (if (eql x 0.0f0) 0 #x-80000000)
 121     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 122         (integer-decode-float x)
 123       (assert (plusp lisp-significand))
 124       (let* ((significand lisp-significand)
 125              (exponent (+ lisp-exponent 23 127))
 126              (unsigned-result
 127               (if (plusp exponent)                      ;if not obviously denormalized
 128                 (do () (nil)
 129                   (cond
 130                     ;; Special termination case for denormalized float number
 131                     ((zerop exponent)
 132                      ;; Denormalized numbers have exponent one greater than
 133                      ;; in the exponent field
 134                      (return (ash significand -1)))
 135                     ;; Ordinary termination case
 136                     ((>= significand (expt 2 23))
 137                      (assert (< 0 significand (expt 2 24)))
 138                      ;; Exponent 0 is reserved for denormalized numbers,
 139                      ;; and 255 is reserved for specials like NaN
 140                      (assert (< 0 exponent 255))
 141                      (return (logior (ash exponent 23)
 142                                      (logand significand (1- (ash 1 23))))))
 143                     (t
 144                      ;; Shift as necessary to set bit 24 of significand
 145                      (setq significand (ash significand 1)
 146                            exponent (1- exponent)))))
 147                 (do () ((zerop exponent)
 148                         ;; Denormalized numbers have exponent one greater than
 149                         ;; the exponent field
 150                         (ash significand -1))
 151                   (unless (zerop (logand significand 1))
 152                     (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
 153                   (setq significand (ash significand -1)
 154                         exponent (1+ exponent))))))
 155         (ecase lisp-sign
 156           ((1)  unsigned-result)
 157           ((-1) (logior unsigned-result (- (expt 2 31)))))))))
 158
 159
 160 #+(or abcl allegro cmu sbcl lispworks)
 161 (defun double-float-bits (x)
 162   (declare (type double-float x))
 163   #+abcl    (values (system:double-float-low-bits float)
 164                     (system:double-float-high-bits float))
 165   #+allegro (multiple-value-bind (us3 us2 us1 us0)
 166                 (excl:double-float-to-shorts float)
 167               (logior (ash us1 16) us0)
 168               (logior (ash us3 16) us2))
 169   #+cmu  (values (kernel:double-float-low-bits float)
 170                  (kernel:double-float-high-bits float))
 171   #+sbcl (values (sb-kernel:double-float-low-bits float)
 172                  (sb-kernel:double-float-high-bits float))
 173   #+lispworks (let ((bits (lispworks-float:double-float-bits float)))
 174                 (values (logand #xffffffff bits)
 175                         (ash bits -32))))
 176
 177 #-(or abcl allegro cmu sbcl lispworks)
 178 (defun double-float-bits (x)
 179   (declare (type double-float x))
 180   (assert (= (float-radix x) 2))
 181   (if (zerop x)
 182     (if (eql x 0.0d0) 0 #x-8000000000000000)
 183     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 184         (integer-decode-float x)
 185       (assert (plusp lisp-significand))
 186       (let* ((significand lisp-significand)
 187              (exponent (+ lisp-exponent 52 1023))
 188              (unsigned-result
 189               (if (plusp exponent)                      ;if not obviously denormalized
 190                 (do () (nil)
 191                   (cond
 192                     ;; Special termination case for denormalized float number
 193                     ((zerop exponent)
 194                      ;; Denormalized numbers have exponent one greater than
 195                      ;; in the exponent field
 196                      (return (ash significand -1)))
 197                     ;; Ordinary termination case
 198                     ((>= significand (expt 2 52))
 199                      (assert (< 0 significand (expt 2 53)))
 200                      ;; Exponent 0 is reserved for denormalized numbers,
 201                      ;; and 2047 is reserved for specials like NaN
 202                      (assert (< 0 exponent 2047))
 203                      (return (logior (ash exponent 52)
 204                                      (logand significand (1- (ash 1 52))))))
 205                     (t
 206                      ;; Shift as necessary to set bit 53 of significand
 207                      (setq significand (ash significand 1)
 208                            exponent (1- exponent)))))
 209                 (do () ((zerop exponent)
 210                         ;; Denormalized numbers have exponent one greater than
 211                         ;; the exponent field
 212                         (ash significand -1))
 213                   (unless (zerop (logand significand 1))
 214                     (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
 215                   (setq significand (ash significand -1)
 216                         exponent (1+ exponent))))))
 217         (let ((result
 218                (ecase lisp-sign
 219                  ((1)  unsigned-result)
 220                  ((-1) (logior unsigned-result (- (expt 2 63)))))))
 221           ;; Return the low bits and the high bits
 222           (values (logand #xffffffff result) (ash result -32)))))))
 223
 224
 225 #+(or abcl allegro cmu sbcl lispworks)
 226 (defun make-single-float (bits)
 227   (declare (type (signed-byte 32) bits))
 228   #+abcl    (system:make-single-float bits)
 229   #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
 230                                          (ldb (byte 16 0) bits))
 231   #+cmu  (kernel:make-single-float bits)
 232   #+sbcl (sb-kernel:make-single-float bits)
 233   #+lispworks (lispworks-float:make-single-float bits))
 234
 235 #-(or abcl allegro cmu sbcl lispworks)
 236 (defun make-single-float (bits)
 237   (declare (type (signed-byte 32) bits))
 238   (cond
 239     ;; IEEE float special cases
 240     ((zerop bits) 0.0)
 241     ((= bits #x-80000000) -0.0)
 242     (t
 243      (let* ((sign (ecase (ldb (byte 1 31) bits)
 244                     (0 1.0)
 245                     (1 -1.0)))
 246             (iexpt (ldb (byte 8 23) bits))
 247             (exponent (if (zerop iexpt)                 ;denormalized
 248                         -126
 249                         (- iexpt 127)))
 250             (mantissa (* (logior (ldb (byte 23 0) bits)
 251                                  (if (zerop iexpt) 0 (ash 1 23)))
 252                          (expt 0.5 23))))
 253        (* sign (expt 2.0 exponent) mantissa)))))
 254
 255
 256 #+(or abcl allegro cmu sbcl lispworks)
 257 (defun make-double-float (low-bits high-bits)
 258   (declare (type (unsigned-byte 32) low-bits)
 259            (type (signed-byte   32) high-bits))
 260   #+abcl (system:make-double-float (logior (ash high 32) low))
 261   #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
 262                                          (ldb (byte 16 0) high)
 263                                          (ldb (byte 16 16) low)
 264                                          (ldb (byte 16 0) low))
 265   #+cmu  (kernel:make-double-float high low)
 266   #+sbcl (sb-kernel:make-double-float high low)
 267   #+lispworks (lispworks-float:make-double-float high low))
 268
 269 #-(or abcl allegro cmu sbcl lispworks)
 270 (defun make-double-float (low-bits high-bits)
 271   (declare (type (unsigned-byte 32) low-bits)
 272            (type (signed-byte   32) high-bits))
 273   (cond
 274     ;; IEEE float special cases
 275     ((and (zerop high-bits) (zerop low-bits)) 0.0d0)
 276     ((and (= high-bits #x-80000000)
 277           (zerop low-bits)) -0.0d0)
 278     (t
 279      (let* ((bits (logior (ash high-bits 32) low-bits))
 280             (sign (ecase (ldb (byte 1 63) bits)
 281                     (0 1.0d0)
 282                     (1 -1.0d0)))
 283             (iexpt (ldb (byte 11 52) bits))
 284             (exponent (if (zerop iexpt)                 ;denormalized
 285                         -1022
 286                         (- iexpt 1023)))
 287             (mantissa (* (logior (ldb (byte 52 0) bits)
 288                                  (if (zerop iexpt) 0 (ash 1 52)))
 289                          (expt 0.5d0 52))))
 290        (* sign (expt 2.0d0 exponent) mantissa)))))