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