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 ;; (uncamel-case "CamelCase") => "Camel-Case"
  92 ;; (uncamel-case "TCPConnection") => "Tcp-Connection"
  93 (defun uncamel-case (string &optional (separator #\-))
  94   (format nil (format nil "~~{~~A~~^~C~~}" separator)
  95           (cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string)))
  96
  97
  98 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
  99   "Given a string 'string', splits it at each of the separators.
 100    Returns a list of the string pieces, with empty pieces removed."
 101   (unless (i= start end)
 102     (loop for this fixnum = start then (i+ next 1)
 103           for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
 104                                              :start this :end end)
 105                                 end)
 106           for piece = (string-right-trim '(#\space) (subseq line this next))
 107           when (not (i= (length piece) 0))
 108             collect piece
 109           until (i>= next end))))
 110
 111
 112 ;;; Managing symbols
 113
 114 (defmacro with-gensyms ((&rest bindings) &body body)
 115   `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
 116      ,@body))
 117
 118 (defun make-lisp-symbol (string)
 119   "Intern a string of the 'package:string' and return the symbol."
 120   (let* ((string (string string))
 121          (colon  (position #\: string))
 122          (pkg    (if colon (subseq string 0 colon) "KEYWORD"))
 123          (sym    (if colon (subseq string (+ colon 1)) string)))
 124     (intern sym pkg)))
 125
 126 (defun fintern (format-string &rest format-args)
 127   "Interns a new symbol in the current package."
 128   (declare (dynamic-extent format-args))
 129   (intern (nstring-upcase (apply #'format nil format-string format-args))))
 130
 131 (defun kintern (format-string &rest format-args)
 132   "Interns a new symbol in the keyword package."
 133   (declare (dynamic-extent format-args))
 134   (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
 135
 136
 137 ;;; Collectors, etc
 138
 139 (defmacro with-collectors ((&rest collection-descriptions) &body body)
 140   (let ((let-bindings  ())
 141         (flet-bindings ())
 142         (dynamic-extents ())
 143         (vobj '#:OBJECT))
 144     (dolist (description collection-descriptions)
 145       (destructuring-bind (place name) description
 146         (let ((vtail (make-symbol (format nil "~A-TAIL" place))))
 147           (setq dynamic-extents
 148                 (nconc dynamic-extents `(#',name)))
 149           (setq let-bindings
 150                 (nconc let-bindings
 151                        `((,place ())
 152                          (,vtail nil))))
 153           (setq flet-bindings
 154                 (nconc flet-bindings
 155                        `((,name (,vobj)
 156                            (setq ,vtail (if ,vtail
 157                                           (setf (cdr ,vtail)  (list ,vobj))
 158                                           (setf ,place (list ,vobj)))))))))))
 159     `(let (,@let-bindings)
 160        (flet (,@flet-bindings)
 161          ,@(and dynamic-extents
 162                 `((declare (dynamic-extent ,@dynamic-extents))))
 163          ,@body))))
 164
 165 (defmacro with-prefixed-accessors (names (prefix object) &body body)
 166   `(with-accessors (,@(loop for name in names
 167                             collect `(,name ,(fintern "~A~A" prefix name))))
 168        ,object
 169      ,@body))
 170
 171
 172 ;;; Functional programming, please
 173
 174 (defun curry (function &rest args)
 175   (if (and args (null (cdr args)))                      ;fast test for length = 1
 176     (let ((arg (car args)))
 177       #'(lambda (&rest more-args)
 178           (apply function arg more-args)))
 179     #'(lambda (&rest more-args)
 180         (apply function (append args more-args)))))
 181
 182 (define-compiler-macro curry (&whole form function &rest args &environment env)
 183   (declare (ignore env))
 184   (if (and (listp function)
 185            (eq (first function) 'function)
 186            (symbolp (second function))
 187            (and args (null (cdr args))))
 188     `#'(lambda (&rest more-args)
 189          (apply ,function ,(car args) more-args))
 190     form))
 191
 192 ;; A parameterized list types for repeated fields (not type-checked!)
 193 (deftype list-of (type)
 194   (if (eq type 'null)
 195     'null
 196     'list))
 197
 198 ;;; Code generation utilities
 199
 200 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
 201 (defvar *camel-case-field-names* nil)
 202
 203 ;; "class-name" -> "ClassName", ("ClassName")
 204 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
 205 (defun class-name->proto (x)
 206   "Given a Lisp class name, returns a Protobufs message or enum name.
 207    The second value is the fully qualified name, as a list."
 208   (let* ((xs (split-string (string x) :separators '(#\.)))
 209          (ns (loop for x in (butlast xs)
 210                    collect (remove-if-not #'alphanumericp
 211                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 212          (nx (car (last xs)))
 213          (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
 214     (values name (append ns (list name)))))
 215
 216 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
 217 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
 218 (defun enum-name->proto (x &optional prefix)
 219   "Given a Lisp enum value name, returns a Protobufs enum value name.
 220    The second value is the fully qualified name, as a list."
 221   (let* ((xs (split-string (string x) :separators '(#\.)))
 222          (ns (loop for x in (butlast xs)
 223                    collect (remove-if-not #'alphanumericp
 224                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 225          (nx (string-upcase (car (last xs))))
 226          (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
 227          ;; Keep underscores, they are standards separators in Protobufs enum names
 228          (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
 229                               (format nil "~{~A~^_~}"
 230                                       (split-string nx :separators *proto-name-separators*)))))
 231     (values name (append ns (list name)))))
 232
 233 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
 234 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
 235 (defun slot-name->proto (x)
 236   "Given a Lisp slot name, returns a Protobufs field name.
 237    The second value is the fully qualified name, as a list."
 238   (let* ((xs (split-string (string x) :separators '(#\.)))
 239          (ns (loop for x in (butlast xs)
 240                    collect (remove-if-not #'alphanumericp
 241                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
 242          (nx (string-downcase (car (last xs))))
 243          (name (if *camel-case-field-names*
 244                  (remove-if-not #'alphanumericp
 245                                 (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
 246                  ;; Keep underscores, they are standards separators in Protobufs field names
 247                  (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
 248                                 (format nil "~{~A~^_~}"
 249                                         (split-string nx :separators *proto-name-separators*))))))
 250     (values name (append ns (list name)))))
 251
 252
 253 ;; "ClassName" -> 'class-name
 254 ;; "cl-user.ClassName" -> 'cl-user::class-name
 255 ;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
 256 (defun proto->class-name (x &optional package)
 257   "Given a Protobufs message or enum type name, returns a Lisp class or type name.
 258    This resolves Protobufs qualified names as best as it can."
 259   (let* ((xs (split-string (substitute #\- #\_ (string-upcase (uncamel-case x)))
 260                            :separators '(#\.)))
 261          (pkg (and (cdr xs) (find-package (first xs))))
 262          (package (or pkg package))
 263          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 264     (values (if package (intern name package) (make-symbol name)) package xs)))
 265
 266 ;; "ENUM_VALUE" -> 'enum-value
 267 ;; "cl-user.ENUM_VALUE" -> 'cl-user::enum-value
 268 ;; "cl-user.OuterClass.ENUM_VALUE" -> 'cl-user::outer-class.enum-value
 269 (defun proto->enum-name (x &optional package)
 270   "Given a Protobufs enum value name, returns a Lisp enum value name.
 271    This resolves Protobufs qualified names as best as it can."
 272   (let* ((xs (split-string (substitute #\- #\_ (string-upcase (uncamel-case x)))
 273                            :separators '(#\.)))
 274          (pkg (and (cdr xs) (find-package (first xs))))
 275          (package (or pkg package))
 276          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 277     (values (if package (intern name package) (make-symbol name)) package xs)))
 278
 279 ;; "slot_name" or "slotName" -> 'slot-name
 280 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
 281 ;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
 282 (defun proto->slot-name (x &optional package)
 283   "Given a Protobufs field value name, returns a Lisp slot name.
 284    This resolves Protobufs qualified names as best as it can."
 285   (let* ((xs (split-string (substitute #\- #\_ (string-upcase (uncamel-case x)))
 286                            :separators '(#\.)))
 287          (pkg (and (cdr xs) (find-package (first xs))))
 288          (package (or pkg package))
 289          (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
 290     (values (if package (intern name package) (make-symbol name)) package xs)))
 291
 292
 293 (define-condition protobufs-warning (warning simple-condition) ())
 294
 295 (defun protobufs-warn (format-control &rest format-arguments)
 296   (warn 'protobufs-warning
 297         :format-control format-control
 298         :format-arguments format-arguments))
 299
 300
 301 #-(or allegro lispworks)
 302 (defmacro without-redefinition-warnings (() &body body)
 303   `(progn ,@body))
 304
 305 #+allegro
 306 (defmacro without-redefinition-warnings (() &body body)
 307   `(excl:without-redefinition-warnings ,@body))
 308
 309 #+lispworks
 310 (defmacro without-redefinition-warnings (() &body body)
 311   `(let ((dspec:*redefinition-action* :quiet)) ,@body))
 312
 313 \f
 314 ;;; Floating point utilities
 315
 316 #+(or abcl allegro cmu sbcl lispworks)
 317 (defun single-float-bits (x)
 318   (declare (type single-float x))
 319   #+abcl    (system:single-float-bits x)
 320   #+allegro (multiple-value-bind (high low)
 321                 (excl:single-float-to-shorts x)
 322               (declare (type (unsigned-byte 16) high low))
 323               (logior (ash high 16) low))
 324   #+cmu  (kernel:single-float-bits x)
 325   #+sbcl (sb-kernel:single-float-bits x)
 326   #+lispworks (lispworks-float:single-float-bits x))
 327
 328 #-(or abcl allegro cmu sbcl lispworks)
 329 (defun single-float-bits (x)
 330   (declare (type single-float x))
 331   (assert (= (float-radix x) 2))
 332   (if (zerop x)
 333     (if (eql x 0.0f0) 0 #x-80000000)
 334     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 335         (integer-decode-float x)
 336       (assert (plusp lisp-significand))
 337       (let* ((significand lisp-significand)
 338              (exponent (+ lisp-exponent 23 127))
 339              (unsigned-result
 340               (if (plusp exponent)                      ;if not obviously denormalized
 341                 (do () (nil)
 342                   (cond
 343                     ;; Special termination case for denormalized float number
 344                     ((zerop exponent)
 345                      ;; Denormalized numbers have exponent one greater than
 346                      ;; in the exponent field
 347                      (return (ash significand -1)))
 348                     ;; Ordinary termination case
 349                     ((>= significand (expt 2 23))
 350                      (assert (< 0 significand (expt 2 24)))
 351                      ;; Exponent 0 is reserved for denormalized numbers,
 352                      ;; and 255 is reserved for specials like NaN
 353                      (assert (< 0 exponent 255))
 354                      (return (logior (ash exponent 23)
 355                                      (logand significand (1- (ash 1 23))))))
 356                     (t
 357                      ;; Shift as necessary to set bit 24 of significand
 358                      (setq significand (ash significand 1)
 359                            exponent (1- exponent)))))
 360                 (do () ((zerop exponent)
 361                         ;; Denormalized numbers have exponent one greater than
 362                         ;; the exponent field
 363                         (ash significand -1))
 364                   (unless (zerop (logand significand 1))
 365                     (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x))
 366                   (setq significand (ash significand -1)
 367                         exponent (1+ exponent))))))
 368         (ecase lisp-sign
 369           ((1)  unsigned-result)
 370           ((-1) (logior unsigned-result (- (expt 2 31)))))))))
 371
 372
 373 #+(or abcl allegro cmu sbcl lispworks)
 374 (defun double-float-bits (x)
 375   (declare (type double-float x))
 376   #+abcl    (values (system:double-float-low-bits x)
 377                     (system:double-float-high-bits x))
 378   #+allegro (multiple-value-bind (us3 us2 us1 us0)
 379                 (excl:double-float-to-shorts x)
 380               (logior (ash us1 16) us0)
 381               (logior (ash us3 16) us2))
 382   #+cmu  (values (kernel:double-float-low-bits x)
 383                  (kernel:double-float-high-bits x))
 384   #+sbcl (values (sb-kernel:double-float-low-bits x)
 385                  (sb-kernel:double-float-high-bits x))
 386   #+lispworks (let ((bits (lispworks-float:double-float-bits x)))
 387                 (values (logand #xffffffff bits)
 388                         (ash bits -32))))
 389
 390 #-(or abcl allegro cmu sbcl lispworks)
 391 (defun double-float-bits (x)
 392   (declare (type double-float x))
 393   (assert (= (float-radix x) 2))
 394   (if (zerop x)
 395     (if (eql x 0.0d0) 0 #x-8000000000000000)
 396     (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 397         (integer-decode-float x)
 398       (assert (plusp lisp-significand))
 399       (let* ((significand lisp-significand)
 400              (exponent (+ lisp-exponent 52 1023))
 401              (unsigned-result
 402               (if (plusp exponent)                      ;if not obviously denormalized
 403                 (do () (nil)
 404                   (cond
 405                     ;; Special termination case for denormalized float number
 406                     ((zerop exponent)
 407                      ;; Denormalized numbers have exponent one greater than
 408                      ;; in the exponent field
 409                      (return (ash significand -1)))
 410                     ;; Ordinary termination case
 411                     ((>= significand (expt 2 52))
 412                      (assert (< 0 significand (expt 2 53)))
 413                      ;; Exponent 0 is reserved for denormalized numbers,
 414                      ;; and 2047 is reserved for specials like NaN
 415                      (assert (< 0 exponent 2047))
 416                      (return (logior (ash exponent 52)
 417                                      (logand significand (1- (ash 1 52))))))
 418                     (t
 419                      ;; Shift as necessary to set bit 53 of significand
 420                      (setq significand (ash significand 1)
 421                            exponent (1- exponent)))))
 422                 (do () ((zerop exponent)
 423                         ;; Denormalized numbers have exponent one greater than
 424                         ;; the exponent field
 425                         (ash significand -1))
 426                   (unless (zerop (logand significand 1))
 427                     (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x))
 428                   (setq significand (ash significand -1)
 429                         exponent (1+ exponent))))))
 430         (let ((result
 431                (ecase lisp-sign
 432                  ((1)  unsigned-result)
 433                  ((-1) (logior unsigned-result (- (expt 2 63)))))))
 434           ;; Return the low bits and the high bits
 435           (values (logand #xffffffff result) (ash result -32)))))))
 436
 437
 438 #+(or abcl allegro cmu sbcl lispworks)
 439 (defun make-single-float (bits)
 440   (declare (type (signed-byte 32) bits))
 441   #+abcl    (system:make-single-float bits)
 442   #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
 443                                          (ldb (byte 16 0) bits))
 444   #+cmu  (kernel:make-single-float bits)
 445   #+sbcl (sb-kernel:make-single-float bits)
 446   #+lispworks (lispworks-float:make-single-float bits))
 447
 448 #-(or abcl allegro cmu sbcl lispworks)
 449 (defun make-single-float (bits)
 450   (declare (type (signed-byte 32) bits))
 451   (cond
 452     ;; IEEE float special cases
 453     ((zerop bits) 0.0)
 454     ((= bits #x-80000000) -0.0)
 455     (t
 456      (let* ((sign (ecase (ldb (byte 1 31) bits)
 457                     (0 1.0)
 458                     (1 -1.0)))
 459             (iexpt (ldb (byte 8 23) bits))
 460             (exponent (if (zerop iexpt)                 ;denormalized
 461                         -126
 462                         (- iexpt 127)))
 463             (mantissa (* (logior (ldb (byte 23 0) bits)
 464                                  (if (zerop iexpt) 0 (ash 1 23)))
 465                          (expt 0.5 23))))
 466        (* sign (expt 2.0 exponent) mantissa)))))
 467
 468
 469 #+(or abcl allegro cmu sbcl lispworks)
 470 (defun make-double-float (low high)
 471   (declare (type (unsigned-byte 32) low)
 472            (type (signed-byte   32) high))
 473   #+abcl (system:make-double-float (logior (ash high 32) low))
 474   #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high)
 475                                          (ldb (byte 16 0) high)
 476                                          (ldb (byte 16 16) low)
 477                                          (ldb (byte 16 0) low))
 478   #+cmu  (kernel:make-double-float high low)
 479   #+sbcl (sb-kernel:make-double-float high low)
 480   #+lispworks (lispworks-float:make-double-float high low))
 481
 482 #-(or abcl allegro cmu sbcl lispworks)
 483 (defun make-double-float (low high)
 484   (declare (type (unsigned-byte 32) low)
 485            (type (signed-byte   32) high))
 486   (cond
 487     ;; IEEE float special cases
 488     ((and (zerop high) (zerop low)) 0.0d0)
 489     ((and (= high #x-80000000)
 490           (zerop low)) -0.0d0)
 491     (t
 492      (let* ((bits (logior (ash high 32) low))
 493             (sign (ecase (ldb (byte 1 63) bits)
 494                     (0 1.0d0)
 495                     (1 -1.0d0)))
 496             (iexpt (ldb (byte 11 52) bits))
 497             (exponent (if (zerop iexpt)                 ;denormalized
 498                         -1022
 499                         (- iexpt 1023)))
 500             (mantissa (* (logior (ldb (byte 52 0) bits)
 501                                  (if (zerop iexpt) 0 (ash 1 52)))
 502                          (expt 0.5d0 52))))
 503        (* sign (expt 2.0d0 exponent) mantissa)))))