;;; ;;;
;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
;;; Protocol buffer defining macros
+;;; Base class for all Protobufs-defined classes
+
+(defclass base-protobuf-message ()
+ ;; Just one slot, to hold a size cached by 'object-size'
+ ((%cached-size :type (or null fixnum)
+ :initform nil))
+ (:documentation
+ "The base class for all user-defined Protobufs messages."))
+
+
+;;; The macros
+
;; Define a schema named 'type', corresponding to a .proto file of that name
(defmacro define-schema (type (&key name syntax package lisp-package import optimize
options documentation)
(lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
(options (remove-options
(loop for (key val) on options by #'cddr
- collect (make-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val))
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val))
"optimize_for" "lisp_package"))
(imports (if (listp import) import (list import)))
(schema (make-instance 'protobuf-schema
:lisp-package (or lisp-pkg (substitute #\- #\_ package))
:imports imports
:options (if optimize
- (append options (list (make-instance 'protobuf-option
- :name "optimize_for"
- :value (if (eq optimize :speed) "SPEED" "CODE_SIZE")
- :type 'symbol)))
+ (append options
+ (list (make-option "optimize_for" (if (eq optimize :speed) "SPEED" "CODE_SIZE") 'symbol)))
options)
:documentation documentation))
(*protobuf* schema)
- (*protobuf-package* (or (find-proto-package lisp-pkg) *package*)))
+ (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
+ (*protobuf-rpc-package* (or (find-proto-package (format nil "~A-~A" lisp-pkg 'rpc)) *package*)))
(process-imports schema imports)
(with-collectors ((forms collect-form))
(dolist (msg messages)
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums schema) (nconc (proto-enums schema) (list model))))
+ (appendf (proto-enums schema) (list model)))
((define-type-alias)
- (setf (proto-type-aliases schema) (nconc (proto-type-aliases schema) (list model))))
+ (appendf (proto-type-aliases schema) (list model)))
((define-message define-extend)
(setf (proto-parent model) schema)
- (setf (proto-messages schema) (nconc (proto-messages schema) (list model)))
+ (appendf (proto-messages schema) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders schema) (nconc (proto-extenders schema) (list model)))))
+ (appendf (proto-extenders schema) (list model))))
((define-service)
- (setf (proto-services schema) (nconc (proto-services schema) (list model)))))))
+ (appendf (proto-services schema) (list model))))))
(let ((var (intern (format nil "*~A*" type) *protobuf-package*)))
`(progn
,@forms
',type ',name)
(map () #'protobufs-warn warnings))))
(setq ,var new-schema)
- (record-protobuf ,var)
- ,@(with-collectors ((messages collect-message))
- (labels ((collect-messages (message)
- (collect-message message)
- (map () #'collect-messages (proto-messages message))))
- (map () #'collect-messages (proto-messages schema)))
- (append
- (mapcar #'(lambda (m) `(record-protobuf ,m)) messages)
- (when (eq optimize :speed)
- (append (mapcar #'generate-object-size messages)
- (mapcar #'generate-serializer messages)
- (mapcar #'generate-deserializer messages)))))
- ,var))))))
+ (record-protobuf ,var))
+ ,@(with-collectors ((messages collect-message))
+ (labels ((collect-messages (message)
+ (collect-message message)
+ (map () #'collect-messages (proto-messages message))))
+ (map () #'collect-messages (proto-messages schema)))
+ (append
+ (mapcar #'(lambda (m) `(record-protobuf ,m)) messages)
+ (when (eq optimize :speed)
+ (append (mapcar #'generate-object-size messages)
+ (mapcar #'generate-serializer messages)
+ (mapcar #'generate-deserializer messages)))))
+ ,var)))))
(defmacro with-proto-source-location ((type name definition-type
&optional pathname start-pos end-pos)
The body consists of the enum values in the form 'name' or (name index)."
(let* ((name (or name (class-name->proto type)))
(options (loop for (key val) on options by #'cddr
- collect (make-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
(conc-name (conc-name-for-type type conc-name))
(index -1)
(enum (make-instance 'protobuf-enum
(with-collectors ((vals collect-val)
(forms collect-form))
(dolist (val values)
- (let* ((idx (if (listp val) (second val) (incf index)))
+ ;; Allow old (name index) and new (name :index index)
+ (let* ((idx (if (listp val)
+ (if (eq (second val) :index) (third val) (second val))
+ (incf index)))
(name (if (listp val) (first val) val))
(val-name (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
(enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name)))
:value val-name
:parent enum)))
(collect-val val-name)
- (setf (proto-values enum) (nconc (proto-values enum) (list enum-val)))))
+ (appendf (proto-values enum) (list enum-val))))
+ (multiple-value-bind (allow bool foundp) (find-option options "allow_alias")
+ (declare (ignore bool))
+ (when (and foundp (not (boolean-true-p allow)))
+ (dolist (v1 (proto-values enum))
+ (dolist (v2 (proto-values enum))
+ (unless (or (eq v1 v2)
+ (not (eql (proto-index v1) (proto-index v2))))
+ (error "The enum values ~S and ~S in ~S have the same index and you have not used 'option allow_alias = true'"
+ (proto-name v1) (proto-name v2) (proto-class enum)))))))
(if alias-for
;; If we've got an alias, define a a type that is the subtype of
;; the Lisp enum so that typep and subtypep work
((with-proto-source-location (,type ,name protobuf-enum ,@source-location)
,@forms))))))
+;; Helper for message-like forms
+(defun generate-message-forms (type fields env &aux (index 0))
+ "Generates the forms used by DEFINE-MESSAGE and DEFINE-GROUP."
+ (with-accessors ((alias-for proto-alias-for)
+ (conc-name proto-conc-name)
+ (documentation proto-documentation))
+ *protobuf*
+ (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 *protobuf*) (list model)))
+ ((define-type-alias)
+ (appendf (proto-type-aliases *protobuf*) (list model)))
+ ((define-message define-extend)
+ (setf (proto-parent model) *protobuf*)
+ (appendf (proto-messages *protobuf*) (list model))
+ (when (eq (proto-message-type model) :extends)
+ (appendf (proto-extenders *protobuf*) (list model))))
+ ((define-group)
+ (setf (proto-parent model) *protobuf*)
+ (appendf (proto-messages *protobuf*) (list model))
+ (when extra-slot
+ (collect-slot extra-slot))
+ (appendf (proto-fields *protobuf*) (list extra-field)))
+ ((define-extension)
+ (appendf (proto-extensions *protobuf*) (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 *protobuf* (proto-index field))) ()
+ "The field ~S overlaps with another field in ~S"
+ (proto-value field) (proto-class *protobuf*))
+ (setq index idx)
+ (when slot
+ (collect-slot slot))
+ (appendf (proto-fields *protobuf*) (list field))))))
+ (if alias-for
+ ;; If we've got an alias, define 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))))))
+ (nconc type-forms forms))))
+
+
;; Define a message named 'name' and a Lisp 'defclass'
(defmacro define-message (type (&key name conc-name alias-for options
documentation source-location)
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)
+ Fields take the form (slot &key type name default reader writer)
'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.
'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-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
(conc-name (conc-name-for-type type conc-name))
(message (make-instance 'protobuf-message
:class type
:options (remove-options options "default" "packed")
:documentation documentation
:source-location source-location))
- (index 0)
;; Only now can we bind *protobuf* to the new message
(*protobuf* message))
- (with-collectors ((slots collect-slot)
- (forms collect-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)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
- ((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
- ((define-message define-extend)
- (setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
- (when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
- ((define-group)
- (setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
- (when extra-slot
- (collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
- ((define-extension)
- (setf (proto-extensions message) (nconc (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))
- (setf (proto-fields message) (nconc (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-form `(deftype ,type () ',alias-for)))
- ;; If no alias, define the class now
- (collect-form `(defclass ,type () (,@slots)
- ,@(and documentation `((:documentation ,documentation))))))
- `(progn
- define-message
- ,message
- ((with-proto-source-location (,type ,name protobuf-message ,@source-location)
- ,@forms))))))
+ `(progn
+ define-message
+ ,message
+ ((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@(generate-message-forms type fields env))))))
(defun conc-name-for-type (type conc-name)
(and conc-name
(typecase conc-name
- ((member t) (format nil "~A-" type))
- ((or string symbol) (string conc-name))
+ ((member t) (format nil "~:@(~A~)-" type))
+ ((or string symbol) (string-upcase (string conc-name)))
(t nil))))
(defmacro define-extension (from to)
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)
+ Fields take the form (slot &key type name default reader writer)
'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.
'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-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
- (message (find-message *protobuf* name))
- (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 (proto-parent message)
- :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)
- (setf (proto-messages extends) (nconc (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
- (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field)))
- (setf (proto-extended-fields extends) (nconc (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
- (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))
- (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))))
- `(progn
- define-extend
- ,extends
- ,forms))))
+ (flet ((gen-extend-field-forms (slot &optional field)
+ (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)))
+ (when field
+ ;; This so that (de)serialization works
+ (setf (proto-reader field) reader
+ (proto-writer field) writer))
+
+ ;; 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'?
+ `(without-redefinition-warnings ()
+ (let ((,stable (tg:make-weak-hash-table :weakness :value :test #'eq)))
+ ,@(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)))
+ ;; 'defsetf' needs to be visible at compile time
+ ,@(and writer `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (defsetf ,reader ,writer)))))))
+ (process-extend-field (field)
+ (setf (proto-message-type field) :extends) ;this field is an extension
+ (appendf (proto-fields *protobuf*) (list field))
+ (appendf (proto-extended-fields *protobuf*) (list field))))
+ (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 (and (eq progn 'progn)
+ (eq model-type 'define-group))
+ ()
+ "The macroexpansion for ~S failed" field)
+ (map () #'collect-form definers)
+ (setf (proto-parent model) extends)
+ (appendf (proto-messages extends) (list model))
+ (when extra-slot
+ (collect-form (gen-extend-field-forms extra-slot)))
+ (process-extend-field 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
+ (collect-form (gen-extend-field-forms slot field)))
+ (process-extend-field field)))))
+ `(progn
+ define-extend
+ ,extends
+ ,forms)))))
(defun index-within-extensions-p (index message)
(let ((extensions (proto-extensions message)))
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)
+ Fields take the form (slot &key type name default reader writer)
'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.
(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-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
+ 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*)))
: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))
- (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)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
- ((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
- ((define-message define-extend)
- (setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
- (when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
- ((define-group)
- (setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
- (when extra-slot
- (collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
- ((define-extension)
- (setf (proto-extensions message) (nconc (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))
- (setf (proto-fields message) (nconc (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-form `(deftype ,type () ',alias-for)))
- ;; If no alias, define the class now
- (collect-form `(defclass ,type () (,@slots)
- ,@(and documentation `((:documentation ,documentation))))))
- `(progn
- define-group
- ,message
- ((with-proto-source-location (,type ,name protobuf-message ,@source-location)
- ,@forms))
- ,mfield
- ,mslot))))
+ `(progn
+ define-group
+ ,message
+ ((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@(generate-message-forms type fields env)))
+ ,mfield
+ ,mslot)))
(defun process-field (field index &key conc-name alias-for)
"Process one field descriptor within 'define-message' or 'define-extend'.
(setq index 19999))
(destructuring-bind (slot &rest other-options
&key type reader writer name (default nil default-p) packed
- options documentation &allow-other-keys) field
- (let* ((idx (if (listp slot) (second slot) (iincf index)))
+ ((: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
(options (append
(loop for (key val) on other-options by #'cddr
unless (member key '(:type :reader :writer :name :default :packed :documentation))
- collect (make-instance 'protobuf-option
- :name (slot-name->proto key)
- :value val))
+ collect (make-option (slot-name->proto key) val))
(loop for (key val) on options by #'cddr
- collect (make-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))))
+ 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)
'name' can be used to override the defaultly generated Protobufs service name.
'options' is a set of keyword/value pairs, both of which are strings.
- The body is a set of method specs of the form (name (input-type output-type) &key options).
+ The body is a set of method specs of the form (name (input-type [=>] output-type) &key options).
'input-type' and 'output-type' may also be of the form (type &key name)."
(let* ((name (or name (class-name->proto type)))
(options (loop for (key val) on options by #'cddr
- collect (make-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
(service (make-instance 'protobuf-service
:class type
:name name
(index 0))
(with-collectors ((forms collect-form))
(dolist (method method-specs)
- (destructuring-bind (function (input-type output-type)
+ (destructuring-bind (function (&rest types)
&key name options documentation source-location) method
- (let* ((input-name (and (listp input-type)
+ (let* ((input-type (first types))
+ (output-type (if (string= (string (second types)) "=>") (third types) (second types)))
+ (streams-type (if (string= (string (second types)) "=>")
+ (getf (cdddr types) :streams)
+ (getf (cddr types) :streams)))
+ (input-name (and (listp input-type)
(getf (cdr input-type) :name)))
(input-type (if (listp input-type) (car input-type) input-type))
(output-name (and (listp output-type)
(getf (cdr output-type) :name)))
(output-type (if (listp output-type) (car output-type) output-type))
+ (streams-name (and (listp streams-type)
+ (getf (cdr streams-type) :name)))
+ (streams-type (if (listp streams-type) (car streams-type) streams-type))
(options (loop for (key val) on options by #'cddr
- collect (make-instance 'protobuf-option
- :name (if (symbolp key) (slot-name->proto key) key)
- :value val)))
- (package *protobuf-package*)
- (client-fn function)
- (server-fn (intern (format nil "~A-~A" 'do function) package))
+ collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
+ (package *protobuf-rpc-package*)
+ (client-fn (intern (format nil "~A-~A" 'call function) package))
+ (server-fn (intern (format nil "~A-~A" function 'impl) package))
(method (make-instance 'protobuf-method
:class function
:name (or name (class-name->proto function))
:input-name (or input-name (class-name->proto input-type))
:output-type output-type
:output-name (or output-name (class-name->proto output-type))
+ :streams-type streams-type
+ :streams-name (and streams-type
+ (or streams-name (class-name->proto streams-type)))
:index (iincf index)
:options options
:documentation documentation
:source-location source-location)))
- (setf (proto-methods service) (nconc (proto-methods service) (list method)))
+ (appendf (proto-methods service) (list method))
;; The following are the hooks to an RPC implementation
(let* ((vrequest (intern (symbol-name 'request) package))
(vchannel (intern (symbol-name 'channel) package))
;; response as an application object.
(collect-form `(defgeneric ,client-fn (,vchannel ,vrequest &key ,vcallback)
,@(and documentation `((:documentation ,documentation)))
- #-sbcl (declare (values ,output-type))
+ #+(or ccl)
+ (declare (values ,output-type))
(:method (,vchannel (,vrequest ,input-type) &key ,vcallback)
(declare (ignorable ,vchannel ,vcallback))
(let ((call (and *rpc-package* *rpc-call-function*)))
;; The RPC code provides the channel classes and does (de)serialization, etc
(collect-form `(defgeneric ,server-fn (,vchannel ,vrequest)
,@(and documentation `((:documentation ,documentation)))
- #-sbcl (declare (values ,output-type))))))))
+ #+(or ccl)
+ (declare (values ,output-type))))))))
`(progn
define-service
,service
'serializer' is a function that takes a Lisp object and generates a Protobufs object.
'deserializer' is a function that takes a Protobufs object and generates a Lisp object.
If 'alias-for' is given, no Lisp 'deftype' will be defined."
- (let* ((name (or name (class-name->proto type)))
- (proto (multiple-value-bind (typ cl)
- (lisp-type-to-protobuf-type proto-type)
- (declare (ignore typ))
- (assert (keywordp cl) ()
- "The alias ~S must resolve to a Protobufs primitive type"
- type)
- cl))
- (alias (make-instance 'protobuf-type-alias
- :class type
- :name name
- :lisp-type lisp-type
- :proto-type proto
- :serializer serializer
- :deserializer deserializer
- :qualified-name (make-qualified-name *protobuf* name)
- :parent *protobuf*
- :documentation documentation
- :source-location source-location)))
- (with-collectors ((forms collect-form))
- (if alias-for
- ;; If we've got an alias, define a a type that is the subtype of
- ;; the Lisp enum so that typep and subtypep work
- (unless (eq type alias-for)
- (collect-form `(deftype ,type () ',alias-for)))
- ;; If no alias, define the Lisp enum type now
- (collect-form `(deftype ,type () ',lisp-type)))
- `(progn
- define-type-alias
- ,alias
- ((with-proto-source-location (,type ,name protobuf-type-alias ,@source-location)
- ,@forms))))))
+ (multiple-value-bind (type-str proto)
+ (lisp-type-to-protobuf-type proto-type)
+ (assert (keywordp proto) ()
+ "The alias ~S must resolve to a Protobufs primitive type"
+ type)
+ (let* ((name (or name (class-name->proto type)))
+ (alias (make-instance 'protobuf-type-alias
+ :class type
+ :name name
+ :lisp-type lisp-type
+ :proto-type proto
+ :proto-type-str type-str
+ :serializer serializer
+ :deserializer deserializer
+ :qualified-name (make-qualified-name *protobuf* name)
+ :parent *protobuf*
+ :documentation documentation
+ :source-location source-location)))
+ (with-collectors ((forms collect-form))
+ (if alias-for
+ ;; If we've got an alias, define a a type that is the subtype of
+ ;; the Lisp enum so that typep and subtypep work
+ (unless (eq type alias-for)
+ (collect-form `(deftype ,type () ',alias-for)))
+ ;; If no alias, define the Lisp enum type now
+ (collect-form `(deftype ,type () ',lisp-type)))
+ `(progn
+ define-type-alias
+ ,alias
+ ((with-proto-source-location (,type ,name protobuf-type-alias ,@source-location)
+ ,@forms)))))))
\f
;;; Ensure everything in a Protobufs schema is defined
-(defvar *undefined-messages*)
+(defvar *undefined-messages* nil
+ "Bound to a list of undefined messages during schame validation.")
;; A very useful tool during development...
(defun ensure-all-schemas ()
(defgeneric ensure-method (trace service method)
(:method (trace service (method protobuf-method))
(ensure-type trace service method (proto-input-type method))
- (ensure-type trace service method (proto-output-type method))))
+ (ensure-type trace service method (proto-output-type method))
+ (ensure-type trace service method (proto-streams-type method))))
;; 'message' and 'field' can be a message and a field or a service and a method
(defun ensure-type (trace message field type)