Merge branch 'rework-asdf-import'

[cl-protobufs.git] / utilities.lisp

diff --git a/utilities.lisp b/utilities.lisp
index e86846e816a54bd17a48741b3a0a845a2cafda06..d8fedc6a393308afd5265e5ba32d4d86c3b40ecc 100644 (file)
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -1,8 +1,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;                                                                  ;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;                                                                  ;;;

-;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
+;;; Free Software published under an MIT-like license. See LICENSE   ;;;

 ;;;                                                                  ;;;
 ;;;                                                                  ;;;

-;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
+;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;

 ;;;                                                                  ;;;
 ;;; Original author: Scott McKay                                     ;;;
 ;;;                                                                  ;;;
 ;;;                                                                  ;;;
 ;;; Original author: Scott McKay                                     ;;;
 ;;;                                                                  ;;;


@@ -13,6 +13,16 @@
 
 ;;; Optimized fixnum arithmetic
 
 
 ;;; Optimized fixnum arithmetic
 

+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defparameter $optimize-default     '(optimize (speed 1) (safety 3) (debug 3))
+  "Compiler optimization settings for safe, debuggable code.")
+(defparameter $optimize-fast-unsafe '(optimize (speed 3) (safety 0) (debug 0))
+  "Compiler optimization settings for fast, unsafe, hard-to-debug code.")
+
+)       ;eval-when
+
+

 (defmacro i+ (&rest fixnums)
   `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
 
 (defmacro i+ (&rest fixnums)
   `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
 


@@ -60,7 +70,7 @@
 (define-modify-macro idecf (&optional (delta 1)) i-)
 
 (defmacro ildb (bytespec value)
 (define-modify-macro idecf (&optional (delta 1)) i-)
 
 (defmacro ildb (bytespec value)

-  `(ldb ,bytespec (the fixnum ,value)))
+  `(the fixnum (ldb ,bytespec (the fixnum ,value))))

 
 
 ;;; String utilities
 
 
 ;;; String utilities


@@ -77,14 +87,21 @@
        (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
        suffix))
 
        (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
        suffix))
 

+(defun strcat (&rest strings)
+  "Concatenate a bunch of strings."
+  (declare (dynamic-extent strings))
+  (apply #'concatenate 'string strings))
+

 
 ;; (camel-case "camel-case") => "CamelCase"
 (defun camel-case (string &optional (separators '(#\-)))
 
 ;; (camel-case "camel-case") => "CamelCase"
 (defun camel-case (string &optional (separators '(#\-)))

+  "Take a hyphen-separated string and turn it into a camel-case string."

   (let ((words (split-string string :separators separators)))
     (format nil "~{~@(~A~)~}" words)))
 
 ;; (camel-case-but-one "camel-case") => "camelCase"
 (defun camel-case-but-one (string &optional (separators '(#\-)))
   (let ((words (split-string string :separators separators)))
     (format nil "~{~@(~A~)~}" words)))
 
 ;; (camel-case-but-one "camel-case") => "camelCase"
 (defun camel-case-but-one (string &optional (separators '(#\-)))

+  "Take a hyphen-separated string and turn its tail into a camel-case string."

   (let ((words (split-string string :separators separators)))
     (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
 
   (let ((words (split-string string :separators separators)))
     (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
 


@@ -96,6 +113,7 @@
 ;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
 ;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
 (defun uncamel-case (name)
 ;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
 ;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
 (defun uncamel-case (name)

+  "Take a camel-case string and turn it into a hyphen-separated string."

   ;; We need a whole state machine to get this right
   (labels ((uncamel (chars state result)
              (let ((ch (first chars)))
   ;; We need a whole state machine to get this right
   (labels ((uncamel (chars state result)
              (let ((ch (first chars)))


@@ -117,12 +135,15 @@
                      ((digit-char-p ch)
                       (uncamel (rest chars) 'digit 
                                (cons ch result)))
                      ((digit-char-p ch)
                       (uncamel (rest chars) 'digit 
                                (cons ch result)))

-                     ((eql ch #\_)
-                      (uncamel (rest chars) '_
+                     ((or (eql ch #\-) (eql ch #\_))
+                      (uncamel (rest chars) 'dash

                                (cons #\- result)))
                                (cons #\- result)))

+                     ((eql ch #\.)
+                      (uncamel (rest chars) 'dot
+                               (cons #\. result)))

                      (t
                       (error "Invalid name character: ~A" ch))))))
                      (t
                       (error "Invalid name character: ~A" ch))))))

-    (concatenate 'string (nreverse (uncamel (concatenate 'list name) nil ())))))
+    (strcat (nreverse (uncamel (concatenate 'list name) nil ())))))

 
 
 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
 
 
 (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))


@@ -175,9 +196,13 @@
          (intern (string-upcase x) (find-package "KEYWORD")))
         (t nil)))
 
          (intern (string-upcase x) (find-package "KEYWORD")))
         (t nil)))
 

+

 ;;; Collectors, etc
 
 (defmacro with-collectors ((&rest collection-descriptions) &body body)
 ;;; Collectors, etc
 
 (defmacro with-collectors ((&rest collection-descriptions) &body body)

+  "'collection-descriptions' is a list of clauses of the form (coll function).
+   The body can call each 'function' to add a value to 'coll'. 'function'
+   runs in constant time, regardless of the length of the list."

   (let ((let-bindings  ())
         (flet-bindings ())
         (dynamic-extents ())
   (let ((let-bindings  ())
         (flet-bindings ())
         (dynamic-extents ())


@@ -210,6 +235,7 @@
      ,@body))
 
 (defmacro dovector ((var vector &optional value) &body body)
      ,@body))
 
 (defmacro dovector ((var vector &optional value) &body body)

+  "Like 'dolist', but iterates over the vector 'vector'."

   (with-gensyms (vidx vlen vvec)
     `(let* ((,vvec ,vector)
             (,vlen (length ,vvec)))
   (with-gensyms (vidx vlen vvec)
     `(let* ((,vvec ,vector)
             (,vlen (length ,vvec)))


@@ -218,10 +244,25 @@
              do (progn ,@body)
              finally (return ,value)))))
 
              do (progn ,@body)
              finally (return ,value)))))
 

+(defmacro doseq ((var sequence &optional value) &body body)
+  "Iterates over a sequence, using 'dolist' or 'dovector' depending on
+   the type of the sequence. In optimized code, this turns out to be
+   faster than (map () #'f sequence).
+   Note that the body gets expanded twice!"
+  (with-gensyms (vseq)
+    `(let ((,vseq ,sequence))
+       (if (vectorp ,vseq)
+         (dovector (,var ,vseq ,value)
+           ,@body)
+         (dolist (,var ,vseq ,value)
+           ,@body)))))
+

 
 ;;; Functional programming, please
 
 (defun curry (function &rest args)
 
 ;;; Functional programming, please
 
 (defun curry (function &rest args)

+  "Returns a function that applies 'function' to 'args', plus any
+   additional arguments given at the call site."

   (if (and args (null (cdr args)))                      ;fast test for length = 1
     (let ((arg (car args)))
       #'(lambda (&rest more-args)
   (if (and args (null (cdr args)))                      ;fast test for length = 1
     (let ((arg (car args)))
       #'(lambda (&rest more-args)


@@ -240,21 +281,23 @@
     form))
 
 
     form))
 
 

+;;; Types
+

 ;; A parameterized list type for repeated fields
 ;; The elements aren't type-checked
 (deftype list-of (type)
 ;; A parameterized list type for repeated fields
 ;; The elements aren't type-checked
 (deftype list-of (type)

-  (if (eq type 'null)
+  (if (eq type 'nil) ; a list that cannot have any element (element-type nil) is null.

     'null
     'list))
 
 ;; The same, but use a (stretchy) vector
 (deftype vector-of (type)
     'null
     'list))
 
 ;; The same, but use a (stretchy) vector
 (deftype vector-of (type)

-  (if (eq type 'null)
-    'null
-    '(array *)))
+  (if (eq type 'nil); an array that cannot have any element (element-type nil) is of size 0.
+    '(array * (0))
+    '(array * (*))))            ;an 1-dimensional array of any type

 
 ;; This corresponds to the :bytes Protobufs type
 
 ;; This corresponds to the :bytes Protobufs type

-(deftype byte-vector () '(array (unsigned-byte 8)))
+(deftype byte-vector () '(array (unsigned-byte 8) (*)))

 
 (defun make-byte-vector (size)
   (make-array size :element-type '(unsigned-byte 8)))
 
 (defun make-byte-vector (size)
   (make-array size :element-type '(unsigned-byte 8)))


@@ -277,6 +320,18 @@
 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
 (defvar *camel-case-field-names* nil)
 
 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
 (defvar *camel-case-field-names* nil)
 

+(defun find-proto-package (name)
+  "A very fuzzy definition of 'find-package'."
+  (typecase name
+    ((or string symbol)
+     ;; Try looking under the given name and the all-uppercase name
+     (or (find-package (string name))
+         (find-package (string-upcase (string name)))))
+    (cons
+     ;; If 'name' is a list, it's actually a fully-qualified path
+     (or (find-proto-package (first name))
+         (find-proto-package (format nil "~{~A~^.~}" name))))))
+

 ;; "class-name" -> "ClassName", ("ClassName")
 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
 (defun class-name->proto (x)
 ;; "class-name" -> "ClassName", ("ClassName")
 ;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
 (defun class-name->proto (x)


@@ -288,7 +343,9 @@
                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
          (nx (car (last xs)))
          (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
                                           (camel-case (format nil "~A" x) *proto-name-separators*))))
          (nx (car (last xs)))
          (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))

-    (values name (append ns (list name)))))
+    (values name (append ns (list name))
+            ;; This might be the name of a package, too
+            (format nil "~{~A~^.~}" (butlast xs)))))

 
 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
 
 ;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
 ;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")


@@ -305,7 +362,8 @@
          (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
                               (format nil "~{~A~^_~}"
                                       (split-string nx :separators *proto-name-separators*)))))
          (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
                               (format nil "~{~A~^_~}"
                                       (split-string nx :separators *proto-name-separators*)))))

-    (values name (append ns (list name)))))
+    (values name (append ns (list name))
+            (format nil "~{~A~^.~}" (butlast xs)))))

 
 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
 
 ;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
 ;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")


@@ -324,7 +382,8 @@
                  (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
                                 (format nil "~{~A~^_~}"
                                         (split-string nx :separators *proto-name-separators*))))))
                  (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
                                 (format nil "~{~A~^_~}"
                                         (split-string nx :separators *proto-name-separators*))))))

-    (values name (append ns (list name)))))
+    (values name (append ns (list name))
+            (format nil "~{~A~^.~}" (butlast xs)))))

 
 
 ;; "ClassName" -> 'class-name
 
 
 ;; "ClassName" -> 'class-name


@@ -335,10 +394,13 @@
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))

-         (pkg (and (cdr xs) (find-package (first xs))))
-         (package (or pkg package))
-         (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
-    (values (if package (intern name package) (make-symbol name)) package xs)))
+         (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+         (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+         (package (or pkg1 pkgn package))
+         (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+    (values (if package (intern name package) (make-symbol name)) package xs
+            ;; This might be the name of a package, too
+            (format nil "~{~A~^.~}" (butlast xs)))))

 
 ;; "ENUM_VALUE" -> :enum-value
 ;; "cl-user.ENUM_VALUE" -> :enum-value
 
 ;; "ENUM_VALUE" -> :enum-value
 ;; "cl-user.ENUM_VALUE" -> :enum-value


@@ -348,10 +410,12 @@
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))

-         (pkg (and (cdr xs) (find-package (first xs))))
-         (package (or pkg package))
-         (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
-    (values (kintern name) package xs)))
+         (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+         (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+         (package (or pkg1 pkgn package))
+         (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+    (values (kintern name) package xs
+            (format nil "~{~A~^.~}" (butlast xs)))))

 
 ;; "slot_name" or "slotName" -> 'slot-name
 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
 
 ;; "slot_name" or "slotName" -> 'slot-name
 ;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name


@@ -361,11 +425,15 @@
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))
    This resolves Protobufs qualified names as best as it can."
   (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
                            :separators '(#\.)))

-         (pkg (and (cdr xs) (find-package (first xs))))
-         (package (or pkg package))
-         (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
-    (values (if package (intern name package) (make-symbol name)) package xs)))
+         (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+         (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+         (package (or pkg1 pkgn package))
+         (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+    (values (if package (intern name package) (make-symbol name)) package xs
+            (format nil "~{~A~^.~}" (butlast xs)))))
+

 
 

+;;; Warnings

 
 (define-condition protobufs-warning (warning simple-condition) ())
 
 
 (define-condition protobufs-warning (warning simple-condition) ())
 


@@ -388,9 +456,9 @@
   `(let ((dspec:*redefinition-action* :quiet)) ,@body))
 
 \f
   `(let ((dspec:*redefinition-action* :quiet)) ,@body))
 
 \f

-;;; Floating point utilities
+;;; Portable floating point utilities

 
 

-#+(or abcl allegro cmu sbcl lispworks)
+#+(or abcl allegro ccl cmu sbcl lispworks)

 (defun single-float-bits (x)
   (declare (type single-float x))
   #+abcl    (system:single-float-bits x)
 (defun single-float-bits (x)
   (declare (type single-float x))
   #+abcl    (system:single-float-bits x)


@@ -398,11 +466,12 @@
                 (excl:single-float-to-shorts x)
               (declare (type (unsigned-byte 16) high low))
               (logior (ash high 16) low))
                 (excl:single-float-to-shorts x)
               (declare (type (unsigned-byte 16) high low))
               (logior (ash high 16) low))

+  #+ccl (ccl::single-float-bits x)

   #+cmu  (kernel:single-float-bits x)
   #+sbcl (sb-kernel:single-float-bits x)
   #+lispworks (lispworks-float:single-float-bits x))
 
   #+cmu  (kernel:single-float-bits x)
   #+sbcl (sb-kernel:single-float-bits x)
   #+lispworks (lispworks-float:single-float-bits x))
 

-#-(or abcl allegro cmu sbcl lispworks)
+#-(or abcl allegro ccl cmu sbcl lispworks)

 (defun single-float-bits (x)
   (declare (type single-float x))
   (assert (= (float-radix x) 2))
 (defun single-float-bits (x)
   (declare (type single-float x))
   (assert (= (float-radix x) 2))


@@ -447,7 +516,7 @@
           ((-1) (logior unsigned-result (- (expt 2 31)))))))))
 
 
           ((-1) (logior unsigned-result (- (expt 2 31)))))))))
 
 

-#+(or abcl allegro cmu sbcl lispworks)
+#+(or abcl allegro ccl cmu sbcl lispworks)

 (defun double-float-bits (x)
   (declare (type double-float x))
   #+abcl    (values (system:double-float-low-bits x)
 (defun double-float-bits (x)
   (declare (type double-float x))
   #+abcl    (values (system:double-float-low-bits x)


@@ -456,6 +525,9 @@
                 (excl:double-float-to-shorts x)
               (logior (ash us1 16) us0)
               (logior (ash us3 16) us2))
                 (excl:double-float-to-shorts x)
               (logior (ash us1 16) us0)
               (logior (ash us3 16) us2))

+  #+ccl  (multiple-value-bind (high low)
+             (ccl::double-float-bits x)
+           (values low high))

   #+cmu  (values (kernel:double-float-low-bits x)
                  (kernel:double-float-high-bits x))
   #+sbcl (values (sb-kernel:double-float-low-bits x)
   #+cmu  (values (kernel:double-float-low-bits x)
                  (kernel:double-float-high-bits x))
   #+sbcl (values (sb-kernel:double-float-low-bits x)


@@ -464,7 +536,7 @@
                 (values (logand #xffffffff bits)
                         (ash bits -32))))
 
                 (values (logand #xffffffff bits)
                         (ash bits -32))))
 

-#-(or abcl allegro cmu sbcl lispworks)
+#-(or abcl allegro ccl cmu sbcl lispworks)

 (defun double-float-bits (x)
   (declare (type double-float x))
   (assert (= (float-radix x) 2))
 (defun double-float-bits (x)
   (declare (type double-float x))
   (assert (= (float-radix x) 2))


@@ -512,17 +584,18 @@
           (values (logand #xffffffff result) (ash result -32)))))))
 
 
           (values (logand #xffffffff result) (ash result -32)))))))
 
 

-#+(or abcl allegro cmu sbcl lispworks)
+#+(or abcl allegro ccl cmu sbcl lispworks)

 (defun make-single-float (bits)
   (declare (type (signed-byte 32) bits))
   #+abcl    (system:make-single-float bits)
   #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
                                          (ldb (byte 16 0) bits))
 (defun make-single-float (bits)
   (declare (type (signed-byte 32) bits))
   #+abcl    (system:make-single-float bits)
   #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits)
                                          (ldb (byte 16 0) bits))

+  #+ccl  (ccl::host-single-float-from-unsigned-byte-32 bits)

   #+cmu  (kernel:make-single-float bits)
   #+sbcl (sb-kernel:make-single-float bits)
   #+lispworks (lispworks-float:make-single-float bits))
 
   #+cmu  (kernel:make-single-float bits)
   #+sbcl (sb-kernel:make-single-float bits)
   #+lispworks (lispworks-float:make-single-float bits))
 

-#-(or abcl allegro cmu sbcl lispworks)
+#-(or abcl allegro ccl cmu sbcl lispworks)

 (defun make-single-float (bits)
   (declare (type (signed-byte 32) bits))
   (cond
 (defun make-single-float (bits)
   (declare (type (signed-byte 32) bits))
   (cond


@@ -543,7 +616,7 @@
        (* sign (expt 2.0 exponent) mantissa)))))
 
 
        (* sign (expt 2.0 exponent) mantissa)))))
 
 

-#+(or abcl allegro cmu sbcl lispworks)
+#+(or abcl allegro ccl cmu sbcl lispworks)

 (defun make-double-float (low high)
   (declare (type (unsigned-byte 32) low)
            (type (signed-byte   32) high))
 (defun make-double-float (low high)
   (declare (type (unsigned-byte 32) low)
            (type (signed-byte   32) high))


@@ -552,11 +625,12 @@
                                          (ldb (byte 16 0) high)
                                          (ldb (byte 16 16) low)
                                          (ldb (byte 16 0) low))
                                          (ldb (byte 16 0) high)
                                          (ldb (byte 16 16) low)
                                          (ldb (byte 16 0) low))

+  #+ccl  (ccl::double-float-from-bits high low)

   #+cmu  (kernel:make-double-float high low)
   #+sbcl (sb-kernel:make-double-float high low)
   #+lispworks (lispworks-float:make-double-float high low))
 
   #+cmu  (kernel:make-double-float high low)
   #+sbcl (sb-kernel:make-double-float high low)
   #+lispworks (lispworks-float:make-double-float high low))
 

-#-(or abcl allegro cmu sbcl lispworks)
+#-(or abcl allegro ccl cmu sbcl lispworks)

 (defun make-double-float (low high)
   (declare (type (unsigned-byte 32) low)
            (type (signed-byte   32) high))
 (defun make-double-float (low high)
   (declare (type (unsigned-byte 32) low)
            (type (signed-byte   32) high))