;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
-;;; 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 ;;;
;;; ;;;
;;; 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)))))
(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-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 '(#\-)))
(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"
-(defun uncamel-case (string &optional (separator #\-))
- (format nil (format nil "~~{~~A~~^~C~~}" separator)
- (cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string)))
+
+;; (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)
+ ;; 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 '(#\-)))
(intern (string-upcase x) (find-package "KEYWORD")))
(t nil)))
+
;;; Collectors, etc
(defmacro with-collectors ((&rest collection-descriptions) &body body)
form))
+;;; Types
+
;; A parameterized list type for repeated fields
;; The elements aren't type-checked
(deftype list-of (type)
(deftype vector-of (type)
(if (eq type 'null)
'null
- '(array *)))
+ '(array * (*)))) ;an 1-dimensional array of any 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)))
(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)
(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")
(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")
(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
(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 #\- #\_ (string-upcase (uncamel-case x)))
+ (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
(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 #\- #\_ (string-upcase (uncamel-case x)))
+ (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
(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 #\- #\_ (string-upcase (uncamel-case x)))
+ (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) ())
`(let ((dspec:*redefinition-action* :quiet)) ,@body))
\f
-;;; Floating point utilities
+;;; Portable floating point utilities
#+(or abcl allegro cmu sbcl lispworks)
(defun single-float-bits (x)