X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=define-proto.lisp;h=96c5f2f3d00d48517437a37361cab6fc5974d062;hb=HEAD;hp=d3e91f0f4a71c2abaccbab6c4e63f0494dfeb727;hpb=58c795d8647683777a623a270535e1b832f0d664;p=cl-protobufs.git diff --git a/define-proto.lisp b/define-proto.lisp index d3e91f0..96c5f2f 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -2,7 +2,7 @@ ;;; ;;; ;;; 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 ;;; ;;; ;;; @@ -13,6 +13,18 @@ ;;; 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) @@ -33,9 +45,7 @@ (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 @@ -46,14 +56,13 @@ :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) @@ -75,16 +84,16 @@ (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 @@ -99,19 +108,19 @@ ',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) @@ -158,9 +167,7 @@ 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 @@ -190,7 +197,16 @@ :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 @@ -204,6 +220,67 @@ ((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) @@ -219,7 +296,7 @@ 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. @@ -230,9 +307,7 @@ '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 @@ -244,67 +319,19 @@ :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) @@ -327,7 +354,7 @@ 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. @@ -336,157 +363,124 @@ '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))) @@ -511,7 +505,7 @@ 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. @@ -525,9 +519,7 @@ (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*))) @@ -568,63 +560,15 @@ :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'. @@ -646,13 +590,9 @@ (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) @@ -720,9 +660,7 @@ '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 @@ -751,12 +689,10 @@ (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)) @@ -775,7 +711,7 @@ :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)) @@ -795,7 +731,8 @@ ;; 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*))) @@ -816,7 +753,8 @@ ;; 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 @@ -833,43 +771,43 @@ '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))))))) ;;; 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 ()