;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
-;;; 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 ;;;
;;; ;;;
(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 "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)))
(cons #\. result)))
(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 '(#\-)))
;;; 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 ())
,@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)))
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)
+ "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)
;; 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)
- (if (eq type 'null)
- 'null
- '(array * (*)))) ;an 1-dimensional array of any 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) (*)))
(deftype sfixed32 () '(signed-byte 32))
(deftype sfixed64 () '(signed-byte 64))
+;; Type expansion
+(defun type-expand (type)
+ #+allegro (excl:normalize-type type :default type)
+ #+ccl (ccl::type-expand type)
+ #+clisp (ext:type-expand type)
+ #+cmu (kernel:type-expand type)
+ #+lispworks (type:expand-user-type type)
+ #+sbcl (sb-ext:typexpand type)
+ #-(or allegro ccl clisp cmu lispworks sbcl) type)
;;; Code generation utilities
;; Try looking under the given name and the all-uppercase name
(or (find-package (string name))
(find-package (string-upcase (string name)))))
- ((cons)
+ (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))))))
\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)
(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))
((-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)
(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)
(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))
(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
(* 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))
(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))
projects / cl-protobufs.git / blobdiff