mirror of
https://gitlab.com/eql/lqml.git
synced 2025-12-06 10:31:34 -08:00
642 lines
28 KiB
Common Lisp
642 lines
28 KiB
Common Lisp
;;; Copyright 2012-2020 Google LLC
|
|
;;;
|
|
;;; Use of this source code is governed by an MIT-style
|
|
;;; license that can be found in the LICENSE file or at
|
|
;;; https://opensource.org/licenses/MIT.
|
|
|
|
(in-package #:cl-protobufs.implementation)
|
|
|
|
|
|
|
|
;;; Optimized fixnum arithmetic
|
|
|
|
;;; By default we optimize select portions of cl-protobufs code that need to be
|
|
;;; very fast by using *optimize-fast-unsafe*. Serialization is the primary
|
|
;;; example. Use (PUSHNEW :DBG *FEATURES*) to turn this off during development.
|
|
;;; Doing so has exposed bugs in the past.
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
|
|
(defparameter *optimize-fast-unsafe*
|
|
#+dbg '(optimize (speed 1) (safety 3) (debug 3))
|
|
#-dbg '(optimize (speed 3) (safety 0) (debug 0))
|
|
"Compiler optimization settings for fast, unsafe, hard-to-debug code.")
|
|
|
|
) ; eval-when
|
|
|
|
|
|
(defmacro defun-inline (name arglist &body body)
|
|
"Define an inline function with NAME, ARGLIST, and BODY."
|
|
`(progn (declaim (inline ,name))
|
|
(defun ,name ,arglist ,@body)))
|
|
|
|
|
|
(defmacro i+ (&rest fixnums)
|
|
"Do fixnum addition on FIXNUMS."
|
|
`(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
|
|
|
|
(defmacro i- (&rest fixnums)
|
|
"Do fixnum subtraction on FIXNUMS."
|
|
`(the fixnum (- ,@(loop for n in fixnums collect `(the fixnum ,n)))))
|
|
|
|
(defmacro i* (&rest fixnums)
|
|
"Do fixnum multiplication on FIXNUMS."
|
|
`(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n)))))
|
|
|
|
(defmacro i= (&rest fixnums)
|
|
"Check FIXNUMS for equality."
|
|
`(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
|
|
|
|
(defmacro i< (&rest fixnums)
|
|
"Check that FIXNUMS are monotonically increasing left to right."
|
|
`(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
|
|
|
|
(defmacro i<= (&rest fixnums)
|
|
"Check that FIXNUMS are not decreasing, left to right."
|
|
`(<= ,@(loop for n in fixnums collect `(the fixnum ,n))))
|
|
|
|
(defmacro i> (&rest fixnums)
|
|
"Check that FIXNUMS are monotonically decreasing, left to right."
|
|
`(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
|
|
|
|
(defmacro i>= (&rest fixnums)
|
|
"Check that FIXNUMS are not increasing, left to right."
|
|
`(>= ,@(loop for n in fixnums collect `(the fixnum ,n))))
|
|
|
|
(defmacro iash (value count)
|
|
"Shift VALUE left by COUNT places, preserving sign. Negative COUNT shifts right."
|
|
`(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
|
|
|
|
(defmacro ilogior (&rest fixnums)
|
|
"Return the bit-wise or of FIXNUMS."
|
|
(if (cdr fixnums)
|
|
`(the fixnum (logior (the fixnum ,(car fixnums))
|
|
,(if (cddr fixnums)
|
|
`(ilogior ,@(cdr fixnums))
|
|
`(the fixnum ,(second fixnums)))))
|
|
`(the fixnum ,(car fixnums))))
|
|
|
|
(defmacro ilogand (&rest fixnums)
|
|
"Return the bit-wise and of FIXNUMS."
|
|
(if (cdr fixnums)
|
|
`(the fixnum (logand (the fixnum ,(car fixnums))
|
|
,(if (cddr fixnums)
|
|
`(ilogand ,@(cdr fixnums))
|
|
`(the fixnum ,(second fixnums)))))
|
|
`(the fixnum ,(car fixnums))))
|
|
|
|
(define-modify-macro iincf (&optional (delta 1)) i+)
|
|
(define-modify-macro idecf (&optional (delta 1)) i-)
|
|
|
|
(defmacro ildb (bytespec value)
|
|
"Extract the specified BYTESPEC from VALUE, and right justify result."
|
|
`(the fixnum (ldb ,bytespec (the fixnum ,value))))
|
|
|
|
|
|
;;; String utilities
|
|
|
|
(defun starts-with (string prefix)
|
|
"Returns true if STRING matches PREFIX (case insensitive)."
|
|
(and (i>= (length string) (length prefix))
|
|
(string-equal string prefix :end1 (length prefix))
|
|
prefix))
|
|
|
|
(defun ends-with (string suffix)
|
|
"Returns true if STRING matches SUFFIX (case insensitive)."
|
|
(let ((string-len (length string))
|
|
(suffix-len (length suffix)))
|
|
(and (i>= string-len suffix-len)
|
|
(string-equal string suffix :start1 (i- string-len suffix-len))
|
|
suffix)))
|
|
|
|
(defun strcat (&rest strings)
|
|
"Return the concatenation of STRINGS. If no arguments are passed, the empty string is returned."
|
|
(declare (dynamic-extent strings))
|
|
(let ((result (apply #'concatenate 'string strings)))
|
|
(if (and (not (typep result 'base-string))
|
|
(every (lambda (x) (typep x 'base-char)) result))
|
|
(coerce result 'base-string)
|
|
result)))
|
|
|
|
(defun camel-case (string &optional (separators '(#\-)))
|
|
"Convert STRING to camel-case by splitting on any of the SEPARATORS and then joining back together
|
|
after capitalizing each part.
|
|
Ex: (camel-case \"camel-case\") => \"CamelCase\""
|
|
(let ((words (split-string string :separators separators)))
|
|
(format nil "~{~@(~A~)~}" words)))
|
|
|
|
(defun camel-case-but-one (string &optional (separators '(#\-)))
|
|
"Convert STRING to camel-case by splitting on any of the SEPARATORS and then joining back
|
|
together after capitalizing all except the first part.
|
|
Ex: (camel-case-but-one \"camel-case\") => \"camelCase\""
|
|
(let ((words (split-string string :separators separators)))
|
|
(format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
|
|
|
|
|
|
;; NB: uncamel-case is not reversible, i.e., it is lossy w.r.t. the original name.
|
|
;; (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 &optional (separator #\-))
|
|
"Convert NAME from camel-case to a SEPARATOR-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 separator result)
|
|
(cons ch result)))
|
|
((lower digit) (list* ch separator 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
|
|
(protobuf-error "Invalid name character: ~S" ch))))))
|
|
(strcat (nreverse (uncamel (concatenate 'list name) nil ())))))
|
|
|
|
(defun split-string (line &key (start 0) (end (length line)) (separators '(#\-)))
|
|
"Split LINE at each of the characters in SEPARATORS starting at START and ending before END.
|
|
Returns a list strings, with empty strings removed.
|
|
Ex: (split-string \"-a-b\") => (\"a\" \"b\")"
|
|
(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)
|
|
"Bind each symbol in BINDINGS to a gensym'd symbol containing its name."
|
|
`(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b))))
|
|
bindings)
|
|
,@body))
|
|
|
|
(defun lisp-symbol-string (symbol)
|
|
"Returns the string used as the wire format for SYMBOL."
|
|
(case symbol
|
|
((t) "T")
|
|
((nil) "NIL")
|
|
(:t ":T")
|
|
(:nil ":NIL")
|
|
(otherwise
|
|
(if (keywordp symbol)
|
|
(symbol-name symbol)
|
|
(format nil "~A:~A"
|
|
(let ((package (symbol-package symbol)))
|
|
(if package (package-name package) "#"))
|
|
(symbol-name symbol))))))
|
|
|
|
(defun make-lisp-symbol (input-string &optional check-bad-chars)
|
|
"Intern the symbol described by INPUT-STRING. If INPUT-STRING is
|
|
\"nil\" or \"t\" then return nil or t. If string has no colon
|
|
return a keyword symbol.
|
|
Otherwise, STRING should be of the form 'package:string' and the symbol
|
|
PACKAGE::STRING is returned.
|
|
If CHECK-BAD-CHARS is specified, disallow strings with more than one colon
|
|
or strings that have certain other bad characters."
|
|
(let ((string (string-upcase input-string)))
|
|
(cond
|
|
((string= string "T") T)
|
|
((string= string "NIL") NIL)
|
|
(t
|
|
(when check-bad-chars
|
|
(let* ((bad-chars `(#\' #\\ #\"))
|
|
(bad-char (find-if #'(lambda (x) (member x bad-chars)) string)))
|
|
(when bad-char
|
|
(protobuf-error "Invalid symbol character ~S in ~S" bad-char input-string))))
|
|
(let ((pos (position #\: string))
|
|
symbol-name
|
|
package-name)
|
|
(if pos
|
|
(setq symbol-name (subseq string (1+ pos))
|
|
package-name (if (= pos 0) "KEYWORD" (subseq string 0 pos)))
|
|
(setq symbol-name string
|
|
package-name "KEYWORD"))
|
|
(when (and check-bad-chars
|
|
(find #\: symbol-name))
|
|
(protobuf-error "Invalid symbol character ~S in ~S" #\: input-string))
|
|
(if (string= package-name "#")
|
|
(make-symbol symbol-name)
|
|
(let ((package (or (find-package package-name)
|
|
(make-package package-name :use ()))))
|
|
;; Discard 2nd value from intern so that this function returns only 1 value.
|
|
(values (intern symbol-name package)))))))))
|
|
|
|
(defun qualified-symbol-name (symbol)
|
|
"Return a string representing SYMBOL qualified with its package name."
|
|
(let* ((*package* (find-package :keyword)))
|
|
(prin1-to-string symbol)))
|
|
|
|
(defun fintern (format-string &rest format-args)
|
|
"Interns a new symbol in the current package. The symbol name is the result of applying #'format
|
|
to FORMAT-STRING and FORMAT-ARGS."
|
|
(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. The symbol name is the result of applying 'format to
|
|
FORMAT-STRING and FORMAT-ARGS."
|
|
(declare (dynamic-extent format-args))
|
|
(intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
|
|
|
|
(defun keywordify (x)
|
|
"Given a symbol designator X, returns a keyword symbol whose name is (symbol-name X).
|
|
If X is nil, 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 (substitute #\- #\_ (string-upcase x)) (find-package "KEYWORD")))))
|
|
|
|
(defun join-intern (&rest symbols)
|
|
"Given SYMBOLS, return a symbol made by joining the symbol names with a dot, e.g.
|
|
SYMBOL1.SYMBOL2.SYMBOL3. The resulting symbol is interned in the package of the first symbol."
|
|
(when symbols
|
|
(intern (format nil "~{~A~^.~}" symbols)
|
|
(symbol-package (first symbols)))))
|
|
|
|
;;; Collectors, etc
|
|
|
|
(defun proto-slot-function-name (proto-type slot function-type)
|
|
"Create function names for proto fields given their slot name.
|
|
Arguments:
|
|
PROTO-TYPE: The symbol naming a protobuf message, group, etc.
|
|
SLOT: The symbol naming a protobuf field.
|
|
FUNCTION-TYPE: The type of function name to retrieve:
|
|
This can be :has, :get, or :clear (for normal fields).
|
|
This can also be :map-get or :map-rem for the special map functions.
|
|
Finally, it can be :case for the special oneof function."
|
|
(declare (type symbol proto-type slot)
|
|
(type (member :has :internal-has :get :clear :map-get :map-rem
|
|
:case :push :length-of :nth)
|
|
function-type))
|
|
(let ((f-symbol (ecase function-type
|
|
(:has 'has)
|
|
(:internal-has '%%has)
|
|
(:clear 'clear)
|
|
(:get nil)
|
|
(:map-get 'gethash)
|
|
(:map-rem 'remhash)
|
|
(:case 'case)
|
|
(:push 'push)
|
|
(:length-of 'length-of)
|
|
(:nth 'nth))))
|
|
(cond ((member f-symbol '(gethash remhash case))
|
|
(intern (nstring-upcase (format nil "~a.~a-~a"
|
|
(symbol-name proto-type)
|
|
(symbol-name slot)
|
|
f-symbol))
|
|
(symbol-package proto-type)))
|
|
(f-symbol
|
|
(intern (nstring-upcase (format nil "~a.~a-~a"
|
|
(symbol-name proto-type)
|
|
f-symbol
|
|
(symbol-name slot)))
|
|
(symbol-package proto-type)))
|
|
(t
|
|
(intern (nstring-upcase (format nil "~a.~a"
|
|
(symbol-name proto-type)
|
|
(symbol-name slot)))
|
|
(symbol-package proto-type))))))
|
|
|
|
;;; TODO(cgay): use ace.core.collect when that works on CCL and ABCL.
|
|
(defmacro with-collectors ((&rest collection-descriptions) &body body)
|
|
"COLLECTION-DESCRIPTIONS is a list of clauses of the form (collection function).
|
|
The body can call 'function' to add a value to the corresponding 'collection'. Elements are added
|
|
to the ends of the lists, in constant time. Example:
|
|
(with-collectors ((numbers collect-number))
|
|
... (collect-number n) ...)"
|
|
(let ((let-bindings ())
|
|
(flet-bindings ())
|
|
(dynamic-extents ())
|
|
(vobj '#:OBJECT))
|
|
(dolist (description collection-descriptions)
|
|
(destructuring-bind (place name) description
|
|
(let ((vtail (make-symbol (format nil "~A-TAIL" place))))
|
|
(setq dynamic-extents
|
|
(nconc dynamic-extents `(#',name)))
|
|
(setq let-bindings
|
|
(nconc let-bindings
|
|
`((,place ())
|
|
(,vtail nil))))
|
|
(setq flet-bindings
|
|
(nconc flet-bindings
|
|
`((,name (,vobj)
|
|
(setq ,vtail (if ,vtail
|
|
(setf (cdr ,vtail) (list ,vobj))
|
|
(setf ,place (list ,vobj)))))))))))
|
|
`(let (,@let-bindings)
|
|
(flet (,@flet-bindings)
|
|
,@(and dynamic-extents
|
|
`((declare (dynamic-extent ,@dynamic-extents))))
|
|
,@body))))
|
|
|
|
(defmacro dovector ((var vector &optional result) &body body)
|
|
"Like DOLIST, but iterates over VECTOR binding VAR to each successive element.
|
|
Returns RESULT."
|
|
`(when ,vector
|
|
(loop for ,var across ,vector
|
|
do (progn ,@body)
|
|
finally (return ,result))))
|
|
|
|
(defmacro doseq ((var sequence &optional result) &body body)
|
|
"Iterates over SEQUENCE, binding VAR to each element in turn. Uses DOLIST or DOVECTOR depending on
|
|
the type of the sequence. In optimized code, this turns out to be faster than (map () #'f
|
|
sequence). Returns RESULT."
|
|
(with-gensyms (vseq vbody)
|
|
`(flet ((,vbody (,var) ,@body))
|
|
(let ((,vseq ,sequence))
|
|
(if (vectorp ,vseq)
|
|
(dovector (,var ,vseq ,result)
|
|
(,vbody ,var))
|
|
(dolist (,var ,vseq ,result)
|
|
(,vbody ,var)))))))
|
|
|
|
|
|
(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)))
|
|
|
|
|
|
;;; Types
|
|
|
|
;; 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))
|
|
|
|
;; A parameterized vector type for repeated fields. The elements aren't type-checked.
|
|
(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 can't be simple-vector because #() is used as the default in some places. Fix it.
|
|
;;; This corresponds to the :bytes protobuf type.
|
|
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
|
|
|
|
(defun make-byte-vector (size &key adjustable)
|
|
"Make a byte vector of length SIZE, optionally ADJUSTABLE."
|
|
(make-array size :element-type '(unsigned-byte 8)
|
|
:adjustable adjustable))
|
|
|
|
(defconstant +field-number-bits+ 29
|
|
"Number of bits in a field number.")
|
|
|
|
(defconstant +max-field-number+ (- (ash 1 +field-number-bits+) 1)
|
|
"Maximum field number is 2^29 - 1")
|
|
|
|
(deftype field-number () `(integer 0 ,+max-field-number+))
|
|
|
|
;; The protobuf 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 () '(unsigned-byte 32))
|
|
(deftype fixed64 () '(unsigned-byte 64))
|
|
(deftype sfixed32 () '(signed-byte 32))
|
|
(deftype sfixed64 () '(signed-byte 64))
|
|
|
|
(defun fixed-width-integer-type-p (type)
|
|
"Check whether TYPE can be serialized in a fixed number of bits."
|
|
(member type '(fixed32 fixed64 sfixed32 sfixed64)))
|
|
|
|
(defun zigzag-encoded-type-p (type)
|
|
"Check whether TYPE should be zigzag encoded on the wire."
|
|
(member type '(sint32 sint64)))
|
|
|
|
(defun type-expand (type)
|
|
"Convert TYPE into an equivalent type, removing all references to derived types."
|
|
#+(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
|
|
|
|
(defparameter *proto-name-separators* '(#\- #\_ #\/ #\space)
|
|
"List of characters to use when splitting Lisp names apart to convert to protobuf names.")
|
|
|
|
(defparameter *camel-case-field-names* nil
|
|
"If true, generate camelCase field names, otherwise generate snake_case field names.")
|
|
|
|
(defun find-proto-package (name)
|
|
"Find a package named NAME, using various heuristics."
|
|
(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")
|
|
;;; TODO(cgay): this would be more appropriately named lisp-name->proto-name.
|
|
(defun class-name->proto (lisp-type-name)
|
|
"Returns the protobuf message or enum name (a string) associated with
|
|
LISP-TYPE-NAME (a symbol or string)."
|
|
(let* ((full-path (split-string (string lisp-type-name) :separators '(#\.)))
|
|
(name-part (first (last full-path))))
|
|
(remove-if-not #'alphanumericp (camel-case name-part *proto-name-separators*))))
|
|
|
|
;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
|
|
;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
|
|
(defun enum-name->proto (enum-value-name &optional prefix)
|
|
"Returns the protobuf enum value name associated with the Lisp ENUM-VALUE-NAME (a string).
|
|
Strip PREFIX from the returned name, if supplied."
|
|
(let* ((xs (split-string (string enum-value-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 standard 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*)))))
|
|
name))
|
|
|
|
;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
|
|
;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
|
|
(defun slot-name->proto (slot-name)
|
|
"Returns the protobuf field name associated with a Lisp SLOT-NAME (a string)."
|
|
(let* ((xs (split-string (string slot-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 standard 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*))))))
|
|
name))
|
|
|
|
;; "foo.bar.Baz" -> 'FOO.BAR::BAZ
|
|
;; "foo_bar.bar.Baz" -> 'FOO-BAR.BAR::BAZ
|
|
(defun proto-to-class (proto-name &key (add-cl-protobufs t))
|
|
"Turn a proto name into a Lisp structure class name.
|
|
Parameters:
|
|
PROTO-NAME: A proto name will have a package seperated with '.', all
|
|
in lower case. The class name will be uppercase first, possibility
|
|
with '.'.
|
|
ADD-CL-PROTOBUFS: If true prepend 'CL-PROTOBUFS.' to the expected package
|
|
name found in proto name."
|
|
(let* ((first-upcase-position
|
|
(position-if #'upper-case-p proto-name))
|
|
(name
|
|
(subseq proto-name first-upcase-position))
|
|
(package
|
|
(substitute
|
|
#\- #\_
|
|
(string-upcase (subseq proto-name 0
|
|
(1- first-upcase-position))))))
|
|
(when add-cl-protobufs
|
|
(setf package (concatenate 'string "CL-PROTOBUFS." package)))
|
|
(proto->class-name name package)))
|
|
|
|
;; "ClassName" -> 'class-name
|
|
;; "cl-user.ClassName" -> 'cl-user::class-name
|
|
;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class
|
|
(defun proto->class-name (proto-name &optional package)
|
|
"Returns a Lisp type name (a symbol) for the protobuf message named PROTO-NAME.
|
|
PROTO-NAME is a dotted string naming a proto message type, e.g., 'package.OuterClass.InnerClass'.
|
|
If PACKAGE is non-nil and PROTO-NAME doesn't contain any dots the returned symbol is interned
|
|
into PACKAGE, otherwise an uninterned symbol in the current package is returned."
|
|
(let* ((full-path
|
|
(split-string (substitute #\- #\_ (uncamel-case proto-name))
|
|
:separators '(#\.)))
|
|
(top-level (first full-path))
|
|
(path-from-top (rest full-path))
|
|
(path-part (butlast full-path))
|
|
(name-part (last full-path))
|
|
(pkg1 (when path-from-top (find-proto-package top-level)))
|
|
;; TODO(dlroxe) Next line is faithful to original implementation, but
|
|
;; TODO(dlroxe) s/path-part/name-part would make more sense to me.
|
|
(pkgn (when path-from-top (find-proto-package path-part)))
|
|
(package (or pkg1 pkgn package))
|
|
(name (nstring-upcase
|
|
(format nil "~{~A~^.~}" (cond (pkg1 path-from-top)
|
|
(pkgn name-part)
|
|
(t full-path))))))
|
|
(if package
|
|
(intern name package)
|
|
(make-symbol name))))
|
|
|
|
;; "ENUM_VALUE" -> :enum-value
|
|
;; "cl-user.ENUM_VALUE" -> :enum-value
|
|
;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value
|
|
(defun proto->enum-name (enum-name)
|
|
"Returns a Lisp enum value (a keyword symbol) for the protobuf enum value named ENUM-NAME.
|
|
ENUM-NAME is a dotted string naming a proto enum value, e.g., 'package.OuterClass.ENUM_VALUE'."
|
|
(let* ((xs (split-string (substitute #\- #\_ (uncamel-case enum-name))
|
|
:separators '(#\.)))
|
|
(pkg1 (and (cdr xs) (find-proto-package (first xs))))
|
|
(pkgn (and (cdr xs) (find-proto-package (butlast xs)))))
|
|
(kintern (format nil "~{~A~^.~}" (cond (pkg1 (cdr xs))
|
|
(pkgn (last xs))
|
|
(t 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
|
|
;; TODO(cgay): Can package default to *package* now that we've gotten rid of *protobuf-package*?
|
|
;; What's the use case for returning an uninterned symbol?
|
|
(defun proto->slot-name (field-name &optional package)
|
|
"Returns a Lisp slot name (a symbol) for the protobuf field named FIELD-NAME.
|
|
FIELD-NAME is a dotted string naming a proto message field, e.g.,
|
|
'package.OuterClass.field_name'. If PACKAGE is non-nil and FIELD-NAME doesn't contain any dots
|
|
the returned symbol is interned into PACKAGE, otherwise an uninterned symbol in the current
|
|
package is returned."
|
|
(let* ((xs (split-string (substitute #\- #\_ (uncamel-case field-name))
|
|
: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 (nstring-upcase
|
|
(format nil "~{~A~^.~}" (cond (pkg1 (cdr xs))
|
|
(pkgn (last xs))
|
|
(t xs))))))
|
|
(if package
|
|
(intern name package)
|
|
(make-symbol name))))
|
|
|
|
(defun scalarp (type)
|
|
"Returns true if the given protobuf type TYPE is a scalar type. Scalar
|
|
types are defined by the protobuf documentation. The cl-protobufs specific
|
|
type `symbol' is included as a scalar type, as it is treated as a synonym
|
|
to the `string' type. This is because symbols are transmitted as strings,
|
|
which are scalars, and then converted based on the lisp_type of the field.
|
|
|
|
https://developers.google.com/protocol-buffers/docs/proto#scalar "
|
|
(member type '(double-float float int32 int64 uint32 uint64 sint32
|
|
sint32 sint64 fixed32 fixed64 sfixed32 sfixed64
|
|
boolean string byte-vector symbol)))
|
|
|
|
(defun packed-type-p (type)
|
|
"Returns true if the given protobuf TYPE can use a packed field."
|
|
(check-type type symbol)
|
|
(not (null (member type '(int32 int64 uint32 uint64 sint32 sint64
|
|
fixed32 fixed64 sfixed32 sfixed64
|
|
boolean float double-float)))))
|
|
|
|
;;; Warnings
|
|
|
|
(define-condition protobufs-warning (warning simple-condition) ())
|
|
|
|
(defun protobufs-warn (format-control &rest format-arguments)
|
|
"Signal a protobufs-warning condition using FORMAT-CONTROL and FORMAT-ARGUMENTS
|
|
to generate the warning message."
|
|
(warn 'protobufs-warning ; NOLINT
|
|
:format-control format-control
|
|
:format-arguments format-arguments))
|
|
|
|
|
|
#-(or allegro lispworks)
|
|
(defmacro without-redefinition-warnings (() &body body) ; lint: disable=MISSING-DOCUMENTATION
|
|
`(progn ,@body))
|
|
|
|
#+allegro
|
|
(defmacro without-redefinition-warnings (() &body body) ; lint: disable=MISSING-DOCUMENTATION
|
|
`(excl:without-redefinition-warnings ,@body))
|
|
|
|
#+lispworks
|
|
(defmacro without-redefinition-warnings (() &body body) ; lint: disable=MISSING-DOCUMENTATION
|
|
`(let ((dspec:*redefinition-action* :quiet)) ,@body))
|