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