asdf-support: simplify do-process-import internals

[cl-protobufs.git] / utilities.lisp

diff --git a/utilities.lisp b/utilities.lisp
index 29e8a5224fb3e92af9e7948e732da562984d8648..d524371058ec9b1d5901e7fa749bdbbd701eda01 100644 (file)
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -258,6 +258,11 @@
            ,@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)
@@ -286,15 +291,15 @@
 ;; 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.
+  (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)
-  (if (eq type 'nil); an array that cannot have any element (element-type nil) is of size 0.
+  (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
+    '(array * (*))))            ;a 1-dimensional array of any type
 
 ;; This corresponds to the :bytes Protobufs type
 (deftype byte-vector () '(array (unsigned-byte 8) (*)))
@@ -314,11 +319,23 @@
 (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)
+
 
 ;;; Code generation utilities
 
-(defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
-(defvar *camel-case-field-names* nil)
+(defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
+(defparameter *camel-case-field-names* nil)
 
 (defun find-proto-package (name)
   "A very fuzzy definition of 'find-package'."
@@ -458,7 +475,7 @@
 \f
 ;;; 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)
@@ -466,11 +483,12 @@
                 (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))
 
-#-(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))
@@ -515,7 +533,7 @@
           ((-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)
@@ -524,6 +542,9 @@
                 (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)
@@ -532,7 +553,7 @@
                 (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))
@@ -580,17 +601,18 @@
           (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))
+  #+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))
 
-#-(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
@@ -611,7 +633,7 @@
        (* 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))
@@ -620,11 +642,12 @@
                                          (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))
 
-#-(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))