+ (let ((to (etypecase to
+ (integer to)
+ (symbol (if (string-equal to "MAX") #.(1- (ash 1 29)) to)))))
+ `(progn
+ define-extension
+ ,(make-instance 'protobuf-extension
+ :from from
+ :to (if (eq to 'max) #.(1- (ash 1 29)) to))
+ ())))
+
+(defmacro define-extend (type (&key name conc-name options documentation)
+ &body fields &environment env)
+ "Define an extension to the message named 'type'.
+ 'name' can be used to override the defaultly generated Protobufs message name.
+ The body consists only of fields.
+ 'options' is a set of keyword/value pairs, both of which are strings.
+
+ Fields take the form (slot &key type name default reader)
+ 'slot' can be either a symbol giving the field name, or a list whose
+ first element is the slot name and whose second element is the index.
+ 'type' is the type of the slot.
+ 'name' can be used to override the defaultly generated Protobufs field name.
+ 'default' is the default value for the slot.
+ 'reader' is a Lisp slot reader function to use to get the value, instead of
+ using 'slot-value'; this is often used when aliasing an existing class.
+ 'writer' is a Lisp slot writer function to use to set the value."
+ (let* ((name (or name (class-name->proto type)))
+ (options (loop for (key val) on options by #'cddr
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
+ (message (find-message *protobuf* type))
+ (conc-name (or (conc-name-for-type type conc-name)
+ (and message (proto-conc-name message))))
+ (alias-for (and message (proto-alias-for message)))
+ (extends (and message
+ (make-instance 'protobuf-message
+ :class (proto-class message)
+ :name (proto-name message)
+ :qualified-name (proto-qualified-name message)
+ :parent *protobuf*
+ :alias-for alias-for
+ :conc-name conc-name
+ :enums (copy-list (proto-enums message))
+ :messages (copy-list (proto-messages message))
+ :fields (copy-list (proto-fields message))
+ :extensions (copy-list (proto-extensions message))
+ :options (remove-options
+ (or options (copy-list (proto-options message))) "default" "packed")
+ :message-type :extends ;this message is an extension
+ :documentation documentation
+ :type-aliases (copy-list (proto-type-aliases message)))))
+ ;; Only now can we bind *protobuf* to the new extended message
+ (*protobuf* extends)
+ (index 0))
+ (assert message ()
+ "There is no message named ~A to extend" name)
+ (assert (eq type (proto-class message)) ()
+ "The type ~S doesn't match the type of the message being extended ~S"
+ type message)
+ (with-collectors ((forms collect-form))
+ (dolist (field fields)
+ (assert (not (member (car field)
+ '(define-enum define-message define-extend define-extension
+ define-type-alias))) ()
+ "The body of ~S can only contain field and group definitions" 'define-extend)
+ (case (car field)
+ ((define-group)
+ (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
+ (macroexpand-1 field env)
+ (assert (eq progn 'progn) ()
+ "The macroexpansion for ~S failed" field)
+ (map () #'collect-form definers)
+ (ecase model-type
+ ((define-group)
+ (setf (proto-parent model) extends)
+ (appendf (proto-messages extends) (list model))
+ (when extra-slot
+ ;;--- Refactor to get rid of all this duplicated code!
+ (let* ((inits (cdr extra-slot))
+ (sname (car extra-slot))
+ (stable (fintern "~A-VALUES" sname))
+ (stype (getf inits :type))
+ (reader (or (getf inits :accessor)
+ (getf inits :reader)
+ (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
+ *protobuf-package*)))
+ (writer (or (getf inits :writer)
+ (intern (format nil "~A-~A" 'set reader) *protobuf-package*)))
+ (default (getf inits :initform)))
+ (collect-form `(without-redefinition-warnings ()
+ (let ((,stable #+ccl (make-hash-table :test #'eq :weak t)
+ #+sbcl (make-hash-table :test #'eq :weakness :value)))
+ ,@(and reader `((defmethod ,reader ((object ,type))
+ (gethash object ,stable ,default))))
+ ,@(and writer `((defmethod ,writer ((object ,type) value)
+ (declare (type ,stype value))
+ (setf (gethash object ,stable) value))))
+ ;; For Python compatibility
+ (defmethod get-extension ((object ,type) (slot (eql ',sname)))
+ (values (gethash object ,stable ,default)))
+ (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
+ (setf (gethash object ,stable) value))
+ (defmethod has-extension ((object ,type) (slot (eql ',sname)))
+ (multiple-value-bind (value foundp)
+ (gethash object ,stable)
+ (declare (ignore value))
+ foundp))
+ (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
+ (remhash object ,stable)))
+ ,@(and writer
+ ;; 'defsetf' needs to be visible at compile time
+ `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (defsetf ,reader ,writer))))))))
+ (setf (proto-message-type extra-field) :extends) ;this field is an extension
+ (appendf (proto-fields extends) (list extra-field))
+ (appendf (proto-extended-fields extends) (list extra-field))))))
+ (otherwise
+ (multiple-value-bind (field slot idx)
+ (process-field field index :conc-name conc-name :alias-for alias-for)
+ (assert (not (find-field extends (proto-index field))) ()
+ "The field ~S overlaps with another field in ~S"
+ (proto-value field) (proto-class extends))
+ (assert (index-within-extensions-p idx message) ()
+ "The index ~D is not in range for extending ~S"
+ idx (proto-class message))
+ (setq index idx)
+ (when slot
+ (let* ((inits (cdr slot))
+ (sname (car slot))
+ (stable (fintern "~A-VALUES" sname))
+ (stype (getf inits :type))
+ (reader (or (getf inits :accessor)
+ (getf inits :reader)
+ (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
+ *protobuf-package*)))
+ (writer (or (getf inits :writer)
+ (intern (format nil "~A-~A" 'set reader) *protobuf-package*)))
+ (default (getf inits :initform)))
+ ;; For the extended slots, each slot gets its own table
+ ;; keyed by the object, which lets us avoid having a slot in each
+ ;; instance that holds a table keyed by the slot name
+ ;; Multiple 'define-extends' on the same class in the same image
+ ;; will result in harmless redefinitions, so squelch the warnings
+ ;;--- Maybe these methods need to be defined in 'define-message'?
+ (collect-form `(without-redefinition-warnings ()
+ (let ((,stable #+ccl (make-hash-table :test #'eq :weak t)
+ #+sbcl (make-hash-table :test #'eq :weakness :value)))
+ ,@(and reader `((defmethod ,reader ((object ,type))
+ (gethash object ,stable ,default))))
+ ,@(and writer `((defmethod ,writer ((object ,type) value)
+ (declare (type ,stype value))
+ (setf (gethash object ,stable) value))))
+ (defmethod get-extension ((object ,type) (slot (eql ',sname)))
+ (values (gethash object ,stable ,default)))
+ (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
+ (setf (gethash object ,stable) value))
+ (defmethod has-extension ((object ,type) (slot (eql ',sname)))
+ (multiple-value-bind (value foundp)
+ (gethash object ,stable)
+ (declare (ignore value))
+ foundp))
+ (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
+ (remhash object ,stable)))
+ ,@(and writer
+ `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (defsetf ,reader ,writer))))))
+ ;; This so that (de)serialization works
+ (setf (proto-reader field) reader
+ (proto-writer field) writer)))
+ (setf (proto-message-type field) :extends) ;this field is an extension
+ (appendf (proto-fields extends) (list field))
+ (appendf (proto-extended-fields extends) (list field))))))
+ `(progn
+ define-extend
+ ,extends
+ ,forms))))
+
+(defun index-within-extensions-p (index message)
+ (let ((extensions (proto-extensions message)))
+ (some #'(lambda (ext)
+ (and (i>= index (proto-extension-from ext))
+ (i<= index (proto-extension-to ext))))
+ extensions)))
+
+(defmacro define-group (type (&key index arity name conc-name alias-for reader options
+ documentation source-location)
+ &body fields &environment env)
+ "Define a message named 'type' and a Lisp 'defclass', *and* a field named type.
+ This is deprecated in Protobufs, but if you have to use it, you must give
+ 'index' as the field index and 'arity' of :required, :optional or :repeated.
+ 'name' can be used to override the defaultly generated Protobufs message name.
+ The body consists of fields, or 'define-enum' or 'define-message' forms.
+ 'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
+ If 'alias-for' is given, no Lisp class is defined. Instead, the message will be
+ used as an alias for a class that already exists in Lisp. This feature is intended
+ to be used to define messages that will be serialized from existing Lisp classes;
+ unless you get the slot names or readers exactly right for each field, it will be
+ the case that trying to (de)serialize into a Lisp object won't work.
+ 'options' is a set of keyword/value pairs, both of which are strings.
+
+ Fields take the form (slot &key type name default reader)
+ 'slot' can be either a symbol giving the field name, or a list whose
+ first element is the slot name and whose second element is the index.
+ 'type' is the type of the slot.
+ 'name' can be used to override the defaultly generated Protobufs field name.
+ 'default' is the default value for the slot.
+ 'reader' is a Lisp slot reader function to use to get the value, instead of
+ using 'slot-value'; this is often used when aliasing an existing class.
+ 'writer' is a Lisp slot writer function to use to set the value."
+ (check-type index integer)
+ (check-type arity (member :required :optional :repeated))
+ (let* ((slot (or type (and name (proto->slot-name name *protobuf-package*))))
+ (name (or name (class-name->proto type)))
+ (options (loop for (key val) on options by #'cddr
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
+ (conc-name (conc-name-for-type type conc-name))
+ (reader (or reader
+ (let ((msg-conc (proto-conc-name *protobuf*)))
+ (and msg-conc
+ (intern (format nil "~A~A" msg-conc slot) *protobuf-package*)))))
+ (mslot (unless alias-for
+ `(,slot ,@(case arity
+ (:required
+ `(:type ,type))
+ (:optional
+ `(:type (or ,type null)
+ :initform nil))
+ (:repeated
+ `(:type (list-of ,type)
+ :initform ())))
+ ,@(and reader
+ `(:accessor ,reader))
+ :initarg ,(kintern (symbol-name slot)))))
+ (mfield (make-instance 'protobuf-field
+ :name (slot-name->proto slot)
+ :type name
+ :class type
+ :qualified-name (make-qualified-name *protobuf* (slot-name->proto slot))
+ :parent *protobuf*
+ :required arity
+ :index index
+ :value slot
+ :reader reader
+ :message-type :group))
+ (message (make-instance 'protobuf-message
+ :class type
+ :name name
+ :qualified-name (make-qualified-name *protobuf* name)
+ :parent *protobuf*
+ :alias-for alias-for
+ :conc-name conc-name
+ :options (remove-options options "default" "packed")
+ :message-type :group ;this message is a group
+ :documentation documentation
+ :source-location source-location))
+ (index 0)
+ ;; Only now can we bind *protobuf* to the (group) message
+ (*protobuf* message))
+ (with-collectors ((slots collect-slot)
+ (forms collect-form)
+ ;; The typedef needs to be first in forms otherwise ccl warns.
+ ;; We'll collect them separately and splice them in first.
+ (type-forms collect-type-form))
+ (dolist (field fields)
+ (case (car field)
+ ((define-enum define-message define-extend define-extension define-group
+ define-type-alias)
+ (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
+ (macroexpand-1 field env)
+ (assert (eq progn 'progn) ()
+ "The macroexpansion for ~S failed" field)
+ (map () #'collect-form definers)
+ (ecase model-type
+ ((define-enum)
+ (appendf (proto-enums message) (list model)))
+ ((define-type-alias)
+ (appendf (proto-type-aliases message) (list model)))
+ ((define-message define-extend)
+ (setf (proto-parent model) message)
+ (appendf (proto-messages message) (list model))
+ (when (eq (proto-message-type model) :extends)
+ (appendf (proto-extenders message) (list model))))
+ ((define-group)
+ (setf (proto-parent model) message)
+ (appendf (proto-messages message) (list model))
+ (when extra-slot
+ (collect-slot extra-slot))
+ (appendf (proto-fields message) (list extra-field)))
+ ((define-extension)
+ (appendf (proto-extensions message) (list model))))))
+ (otherwise
+ (multiple-value-bind (field slot idx)
+ (process-field field index :conc-name conc-name :alias-for alias-for)
+ (assert (not (find-field message (proto-index field))) ()
+ "The field ~S overlaps with another field in ~S"
+ (proto-value field) (proto-class message))
+ (setq index idx)
+ (when slot
+ (collect-slot slot))
+ (appendf (proto-fields message) (list field))))))
+ (if alias-for
+ ;; If we've got an alias, define a a type that is the subtype of
+ ;; the Lisp class that typep and subtypep work
+ (unless (or (eq type alias-for) (find-class type nil))
+ (collect-type-form `(deftype ,type () ',alias-for)))
+ ;; If no alias, define the class now
+ (collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message) (,@slots)
+ ,@(and documentation `((:documentation ,documentation))))))
+ `(progn
+ define-group
+ ,message
+ ((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@type-forms
+ ,@forms))
+ ,mfield
+ ,mslot))))
+
+(defun process-field (field index &key conc-name alias-for)
+ "Process one field descriptor within 'define-message' or 'define-extend'.
+ Returns a 'proto-field' object, a CLOS slot form and the incremented field index."
+ (when (i= index 18999) ;skip over the restricted range
+ (setq index 19999))
+ (destructuring-bind (slot &rest other-options
+ &key type reader writer name (default nil default-p) packed
+ ((:index idx)) options documentation &allow-other-keys) field
+ ;; Allow old ((slot index) ...) or new (slot :index ...),
+ ;; but only allow one of those two to be used simultaneously
+ (assert (if idx (not (listp slot)) t) ()
+ "Use either ((slot index) ...) or (slot :index index ...), but not both")
+ (let* ((idx (or idx (if (listp slot) (second slot) (iincf index))))
+ (slot (if (listp slot) (first slot) slot))
+ (reader (or reader
+ (and conc-name
+ (intern (format nil "~A~A" conc-name slot) *protobuf-package*))))
+ (options (append
+ (loop for (key val) on other-options by #'cddr
+ unless (member key '(:type :reader :writer :name :default :packed :documentation))
+ collect (make-option (slot-name->proto key) val))
+ (loop for (key val) on options by #'cddr
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))))
+ (multiple-value-bind (ptype pclass)
+ (clos-type-to-protobuf-type type)
+ (multiple-value-bind (reqd vectorp)
+ (clos-type-to-protobuf-required type)
+ (let* ((default (if (eq reqd :repeated)
+ (if vectorp $empty-vector $empty-list) ;to distinguish between list-of and vector-of
+ (if default-p default $empty-default)))
+ (cslot (unless alias-for
+ `(,slot :type ,type
+ ,@(and reader
+ (if writer
+ `(:reader ,reader)
+ `(:accessor ,reader)))
+ ,@(and writer
+ `(:writer ,writer))
+ :initarg ,(kintern (symbol-name slot))
+ ,@(cond ((eq reqd :repeated)
+ ;; Repeated fields get a container for their elements
+ (if vectorp
+ `(:initform (make-array 5 :fill-pointer 0 :adjustable t))
+ `(:initform ())))
+ ((and (not default-p)
+ (eq reqd :optional)
+ ;; Use unbound for booleans only
+ (not (eq pclass :bool)))
+ `(:initform nil))
+ (default-p
+ `(:initform ,(protobuf-default-to-clos-init default type)))))))
+ (field (make-instance 'protobuf-field
+ :name (or name (slot-name->proto slot))
+ :type ptype
+ :class pclass
+ :qualified-name (make-qualified-name *protobuf* (or name (slot-name->proto slot)))
+ :parent *protobuf*
+ ;; One of :required, :optional or :repeated
+ :required reqd
+ :index idx
+ :value slot
+ :reader reader
+ :writer writer
+ :default default
+ ;; Pack the field only if requested and it actually makes sense
+ :packed (and (eq reqd :repeated) packed t)
+ :options options
+ :documentation documentation)))
+ (values field cslot idx)))))))
+
+(defparameter *rpc-package* nil
+ "The Lisp package that implements RPC.
+ This should be set when an RPC package that uses CL-Protobufs gets loaded.")
+(defparameter *rpc-call-function* nil
+ "The Lisp function that implements RPC client-side calls.
+ This should be set when an RPC package that uses CL-Protobufs gets loaded.")