Merge branch 'refactor-define-proto'

[cl-protobufs.git] / utilities.lisp

diff --git a/utilities.lisp b/utilities.lisp
index 03486b9517838729b873cf10ac7d3ae8b12310a1..d524371058ec9b1d5901e7fa749bdbbd701eda01 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                                     ;;;
 ;;;                                                                  ;;;


@@ -11,97 +11,17 @@
 (in-package "PROTO-IMPL")
 
 
 (in-package "PROTO-IMPL")
 
 

-;;; Code generation utilities
-
-;; "class-name" -> "ClassName"
-(defun class-name->proto (x)
-  "Given a Lisp class name, returns a Protobufs message or enum name."
-  (remove-if-not #'alphanumericp
-                 (camel-case (format nil "~A" x) :separators '(#\- #\_ #\/ #\. #\space))))
-
-;; "enum-value" -> "ENUM_VALUE"
-(defun enum-name->proto (x &optional prefix)
-  "Given a Lisp enum value name, returns a Protobufs enum value name."
-  (let* ((x (string-upcase (string x)))
-         (x (if (and prefix (starts-with x prefix)) (subseq x (length prefix)) x)))
-    (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
-                   (format nil "~{~A~^_~}"
-                           (split-string x :separators '(#\- #\_ #\/ #\. #\space))))))
-
-;; "slot-name" -> "slot_name" or "slotName"
-(defvar *camel-case-field-names* nil)
-(defun slot-name->proto (x)
-  "Given a Lisp slot name, returns a Protobufs field name."
-  (if *camel-case-field-names*
-    (remove-if-not #'alphanumericp
-                   (camel-case-but-one (format nil "~A" x) :separators '(#\- #\_ #\/ #\. #\space)))
-    (let ((x (string-downcase (string x))))
-      (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
-                     (format nil "~{~A~^_~}"
-                             (split-string x :separators '(#\- #\_ #\/ #\. #\space)))))))
-
-
-;; "ClassName" -> "class-name"
-(defun proto->class-name (x &optional package)
-  "Given a Protobufs message or enum type name, returns a Lisp class or type name."
-  (let ((name (nstring-upcase (uncamel-case x))))
-    (if package (intern name package) (make-symbol name))))
-
-;; "ENUM_VALUE" -> "enum-name"
-(defun proto->enum-name (x &optional package)
-  "Given a Protobufs enum value name, returns a Lisp enum value name."
-  (let ((name (format nil "~{~A~^-~}"
-                      (split-string (string-upcase x) :separators '(#\_)))))
-    (if package (intern name package) (make-symbol name))))
-
-;; "slot_name" or "slotName" -> "slot-name"
-(defun proto->slot-name (x &optional package)
-  "Given a Protobufs field value name, returns a Lisp slot name."
-  (let ((name (format nil "~{~A~^-~}" (split-string (nstring-upcase (uncamel-case x)) :separators '(#\_)))))
-    (if package (intern name package) (make-symbol name))))
-
-
-(defun make-lisp-symbol (string)
-  "Intern a string of the 'package:string' and return the symbol."
-  (let* ((string (string string))
-         (colon  (position #\: string))
-         (pkg    (if colon (subseq string 0 colon) "KEYWORD"))
-         (sym    (if colon (subseq string (+ colon 1)) string)))
-    (intern sym pkg)))
-
-#-quux
-(defun fintern (format-string &rest format-args)
-  "Interns a new symbol in the current package."
-  (declare (dynamic-extent format-args))
-  (intern (nstring-upcase (apply #'format nil format-string format-args))))
-
-#-quux
-(defun kintern (format-string &rest format-args)
-  "Interns a new symbol in the keyword package."
-  (declare (dynamic-extent format-args))
-  (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
-
-
-(define-condition protobufs-warning (warning simple-condition) ())
-
-(defun protobufs-warn (format-control &rest format-arguments)
-  (warn 'protobufs-warning
-        :format-control format-control
-        :format-arguments format-arguments))
-
-\f
-;;; Other utilities
+;;; Optimized fixnum arithmetic

 
 

-;; A parameterized list types for repeated fields (not type-checked!)
-(deftype list-of (type)
-  (if (eq type 'null)
-    'null
-    'list))
+(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.")

 
 

-#-quux (progn
+)       ;eval-when

 
 

-;;; Optimized fixnum arithmetic

 
 (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)))))


@@ -150,23 +70,139 @@
 (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))))

 
 
 
 

-;;; Collectors, etc
+;;; String utilities
+
+(defun starts-with (string prefix &key (start 0))
+  "Returns true if 'string' starts with the prefix 'prefix' (case insensitive)."
+  (and (i>= (length string) (i+ start (length prefix)))
+       (string-equal string prefix :start1 start :end1 (i+ start (length prefix)))
+       prefix))
+
+(defun ends-with (string suffix &key (end (length string)))
+  "Returns true if 'string' ends with the prefix 'prefix' (case insensitive)."
+  (and (i>= end (length 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 '(#\-)))
+  "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 '(#\-)))
+  "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))))
+
+
+;; (uncamel-case "CamelCase") => "CAMEL-CASE"
+;; (uncamel-case "TCPConnection") => "TCP-CONNECTION"
+;; (uncamel-case "NewTCPConnection") => "NEW-TCP-CONNECTION"
+;; (uncamel-case "new_RPC_LispService") => "NEW-RPC-LISP-SERVICE"
+;; (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)))
+               (cond ((null chars)
+                      result)
+                     ((upper-case-p ch)
+                      (uncamel (rest chars) 'upper
+                               (case state
+                                 ((upper)
+                                  ;; "TCPConnection" => "TCP-CONNECTION"
+                                  (if (and (second chars) (lower-case-p (second chars)))
+                                    (list* ch #\- result)
+                                    (cons ch result)))
+                                 ((lower digit) (list* ch #\- result))
+                                 (otherwise (cons ch result)))))
+                     ((lower-case-p ch)
+                      (uncamel (rest chars) 'lower
+                               (cons (char-upcase ch) result)))
+                     ((digit-char-p ch)
+                      (uncamel (rest chars) 'digit 
+                               (cons ch result)))
+                     ((or (eql ch #\-) (eql ch #\_))
+                      (uncamel (rest chars) 'dash
+                               (cons #\- result)))
+                     ((eql ch #\.)
+                      (uncamel (rest chars) 'dot
+                               (cons #\. result)))
+                     (t
+                      (error "Invalid name character: ~A" ch))))))
+    (strcat (nreverse (uncamel (concatenate 'list name) nil ())))))
+
+
+(defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
+  "Given a string 'string', splits it at each of the separators.
+   Returns a list of the string pieces, with empty pieces removed."
+  (unless (i= start end)
+    (loop for this fixnum = start then (i+ next 1)
+          for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
+                                             :start this :end end)
+                                end)
+          for piece = (string-right-trim '(#\space) (subseq line this next))
+          when (not (i= (length piece) 0))
+            collect piece
+          until (i>= next end))))
+
+
+;;; Managing symbols

 
 (defmacro with-gensyms ((&rest bindings) &body body)
   `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
      ,@body))
 
 
 (defmacro with-gensyms ((&rest bindings) &body body)
   `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings)
      ,@body))
 

-(defmacro with-prefixed-accessors (names (prefix object) &body body)
-  `(with-accessors (,@(loop for name in names
-                            collect `(,name ,(fintern "~A~A" prefix name))))
-       ,object
-     ,@body))
+(defun make-lisp-symbol (string)
+  "Intern a string of the 'package:string' and return the symbol."
+  (let* ((string (string string))
+         (colon  (position #\: string))
+         (pkg    (if colon (subseq string 0 colon) "KEYWORD"))
+         (sym    (if colon (subseq string (+ colon 1)) string)))
+    (intern sym pkg)))
+
+(defun fintern (format-string &rest format-args)
+  "Interns a new symbol in the current package."
+  (declare (dynamic-extent format-args))
+  (intern (nstring-upcase (apply #'format nil format-string format-args))))
+
+(defun kintern (format-string &rest format-args)
+  "Interns a new symbol in the keyword package."
+  (declare (dynamic-extent format-args))
+  (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
+
+(defun keywordify (x)
+  "Given a symbol designator 'x', return a keyword whose name is 'x'.
+   If 'x' is nil, this returns nil."
+  (check-type x (or string symbol null))
+  (cond ((null x) nil)
+        ((keywordp x) x)
+        ((symbolp x) (keywordify (symbol-name x)))
+        ((zerop (length x)) nil)
+        ((string-not-equal x "nil")
+         (intern (string-upcase x) (find-package "KEYWORD")))
+        (t nil)))
+

 
 

+;;; Collectors, etc

 
 (defmacro with-collectors ((&rest collection-descriptions) &body body)
 
 (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 ())


@@ -192,10 +228,46 @@
                 `((declare (dynamic-extent ,@dynamic-extents))))
          ,@body))))
 
                 `((declare (dynamic-extent ,@dynamic-extents))))
          ,@body))))
 

+(defmacro with-prefixed-accessors (names (prefix object) &body body)
+  `(with-accessors (,@(loop for name in names
+                            collect `(,name ,(fintern "~A~A" prefix name))))
+       ,object
+     ,@body))

 
 

-;;; Function programming, please
+(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)))
+       (loop for ,vidx fixnum from 0 below ,vlen
+             as ,var = (aref ,vvec ,vidx)
+             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)))))
+
+
+(defmacro appendf (place tail)
+  "Append 'tail' to the list given by 'place', then set the place to the new list."
+  `(setf ,place (append ,place ,tail)))
+
+
+;;; Functional programming, please

 
 (defun curry (function &rest args)
 
 (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)


@@ -214,52 +286,196 @@
     form))
 
 
     form))
 
 

-;;; String utilities
+;;; Types

 
 

-(defun starts-with (string prefix &key (start 0))
-  (and (i>= (length string) (i+ start (length prefix)))
-       (string-equal string prefix :start1 start :end1 (i+ start (length prefix)))
-       prefix))
+;; A parameterized list type for repeated fields
+;; The elements aren't type-checked
+(deftype list-of (type)
+  (if (eq type 'nil)            ;a list that cannot have any element (element-type nil) is null
+    'null
+    'list))

 
 

-(defun ends-with (string suffix &key (end (length string)))
-  (and (i>= end (length suffix))
-       (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
-       suffix))
+;; The same, but use a (stretchy) vector
+(deftype vector-of (type)
+  (if (eq type 'nil)            ;an array that cannot have any element (element-type nil) is of size 0
+    '(array * (0))
+    '(array * (*))))            ;a 1-dimensional array of any type
+
+;; This corresponds to the :bytes Protobufs type
+(deftype byte-vector () '(array (unsigned-byte 8) (*)))
+
+(defun make-byte-vector (size)
+  (make-array size :element-type '(unsigned-byte 8)))
+
+;; The Protobufs integer types
+(deftype    int32 () '(signed-byte 32))
+(deftype    int64 () '(signed-byte 64))
+(deftype   uint32 () '(unsigned-byte 32))
+(deftype   uint64 () '(unsigned-byte 64))
+(deftype   sint32 () '(signed-byte 32))
+(deftype   sint64 () '(signed-byte 64))
+(deftype  fixed32 () '(signed-byte 32))
+(deftype  fixed64 () '(signed-byte 64))
+(deftype sfixed32 () '(signed-byte 32))
+(deftype sfixed64 () '(signed-byte 64))
+
+;; Type expansion
+(defun type-expand (type)
+  #+(or abcl xcl) (system::expand-deftype type)
+  #+allegro (excl:normalize-type type :default type)
+  #+ccl (ccl::type-expand type)
+  #+clisp (ext:type-expand type)
+  #+cmu (kernel:type-expand type)
+  #+(or ecl mkcl) (si::expand-deftype type)
+  #+lispworks (type:expand-user-type type)
+  #+sbcl (sb-ext:typexpand type)
+  #-(or abcl allegro ccl clisp cmu ecl lispworks mkcl sbcl xcl) type)

 
 
 
 

-;; (camel-case "camel-case") => "CamelCase"
-(defun camel-case (string &key (separators '(#\-)))
-  (let ((words (split-string string :separators separators)))
-    (format nil "~{~@(~A~)~}" words)))
+;;; Code generation utilities

 
 

-;; (camel-case-but-one "camel-case") => "camelCase"
-(defun camel-case-but-one (string &key (separators '(#\-)))
-  (let ((words (split-string string :separators separators)))
-    (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
+(defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
+(defparameter *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)
+  "Given a Lisp class name, returns a Protobufs message or enum name.
+   The second value is the fully qualified name, as a list."
+  (let* ((xs (split-string (string x) :separators '(#\.)))
+         (ns (loop for x in (butlast xs)
+                   collect (remove-if-not #'alphanumericp
+                                          (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))
+            ;; 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")
+(defun enum-name->proto (x &optional prefix)
+  "Given a Lisp enum value name, returns a Protobufs enum value name.
+   The second value is the fully qualified name, as a list."
+  (let* ((xs (split-string (string x) :separators '(#\.)))
+         (ns (loop for x in (butlast xs)
+                   collect (remove-if-not #'alphanumericp
+                                          (camel-case (format nil "~A" x) *proto-name-separators*))))
+         (nx (string-upcase (car (last xs))))
+         (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx))
+         ;; Keep underscores, they are standards separators in Protobufs enum names
+         (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))
+            (format nil "~{~A~^.~}" (butlast xs)))))
+
+;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
+;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
+(defun slot-name->proto (x)
+  "Given a Lisp slot name, returns a Protobufs field name.
+   The second value is the fully qualified name, as a list."
+  (let* ((xs (split-string (string x) :separators '(#\.)))
+         (ns (loop for x in (butlast xs)
+                   collect (remove-if-not #'alphanumericp
+                                          (camel-case (format nil "~A" x) *proto-name-separators*))))
+         (nx (string-downcase (car (last xs))))
+         (name (if *camel-case-field-names*
+                 (remove-if-not #'alphanumericp
+                                (camel-case-but-one (format nil "~A" nx) *proto-name-separators*))
+                 ;; Keep underscores, they are standards separators in Protobufs field names
+                 (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))
+            (format nil "~{~A~^.~}" (butlast xs)))))
+
+
+;; "ClassName" -> 'class-name
+;; "cl-user.ClassName" -> 'cl-user::class-name
+;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
+(defun proto->class-name (x &optional package)
+  "Given a Protobufs message or enum type name, returns a Lisp class or type name.
+   This resolves Protobufs qualified names as best as it can."
+  (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
+                           :separators '(#\.)))
+         (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
+;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
+(defun proto->enum-name (x &optional package)
+  "Given a Protobufs enum value name, returns a Lisp enum value name.
+   This resolves Protobufs qualified names as best as it can."
+  (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
+                           :separators '(#\.)))
+         (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
+;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name
+(defun proto->slot-name (x &optional package)
+  "Given a Protobufs field value name, returns a Lisp slot name.
+   This resolves Protobufs qualified names as best as it can."
+  (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
+                           :separators '(#\.)))
+         (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)))))

 
 

-;; (uncamel-case "CamelCase") => "Camel-Case"
-(defun uncamel-case (string &key (separator #\-))
-  (format nil (format nil "~~{~~A~~^~C~~}" separator)
-          (cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string)))

 
 

+;;; Warnings

 
 

-(defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
-  (unless (i= start end)
-    (loop for this fixnum = start then (i+ next 1)
-          for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line
-                                             :start this :end end)
-                                end)
-          for piece = (string-right-trim '(#\space) (subseq line this next))
-          when (not (i= (length piece) 0))
-            collect piece
-          until (i>= next end))))
+(define-condition protobufs-warning (warning simple-condition) ())
+
+(defun protobufs-warn (format-control &rest format-arguments)
+  (warn 'protobufs-warning
+        :format-control format-control
+        :format-arguments format-arguments))
+
+
+#-(or allegro lispworks)
+(defmacro without-redefinition-warnings (() &body body)
+  `(progn ,@body))
+    
+#+allegro
+(defmacro without-redefinition-warnings (() &body body)
+  `(excl:without-redefinition-warnings ,@body))

 
 

-)       ;#-quux
+#+lispworks
+(defmacro without-redefinition-warnings (() &body body)
+  `(let ((dspec:*redefinition-action* :quiet)) ,@body))

 
 \f
 
 \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)


@@ -267,11 +483,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))


@@ -316,7 +533,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)


@@ -325,6 +542,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)


@@ -333,7 +553,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))


@@ -381,17 +601,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


@@ -412,7 +633,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))


@@ -421,11 +642,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 (logand high #xffffffff) 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))