;;; 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)
(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
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
: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))))
(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
'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
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ (appendf (proto-enums message) (list model)))
((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
+ (appendf (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)))
+ (appendf (proto-messages message) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ (appendf (proto-extenders message) (list model))))
((define-group)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when extra-slot
(collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
+ (appendf (proto-fields message) (list extra-field)))
((define-extension)
- (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
+ (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)
(setq index idx)
(when slot
(collect-slot slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
+ (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 () (,@slots)
- ,@(and documentation `((:documentation ,documentation))))))
+ (collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message) (,@slots)
+ ,@(and documentation `((:documentation ,documentation))))))
`(progn
define-message
,message
'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)))
(message (find-message *protobuf* type))
(conc-name (or (conc-name-for-type type conc-name)
(and message (proto-conc-name message))))
(ecase model-type
((define-group)
(setf (proto-parent model) extends)
- (setf (proto-messages extends) (nconc (proto-messages extends) (list model)))
+ (appendf (proto-messages extends) (list model))
(when extra-slot
;;--- Refactor to get rid of all this duplicated code!
(let* ((inits (cdr extra-slot))
(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)))
+ (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)
;; '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)))))))
+ (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)
;; 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)))
+ (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)
(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)))))))
+ (appendf (proto-fields extends) (list field))
+ (appendf (proto-extended-fields extends) (list field))))))
`(progn
define-extend
,extends
(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*)))
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ (appendf (proto-enums message) (list model)))
((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
+ (appendf (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)))
+ (appendf (proto-messages message) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ (appendf (proto-extenders message) (list model))))
((define-group)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when extra-slot
(collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
+ (appendf (proto-fields message) (list extra-field)))
((define-extension)
- (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
+ (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)
(setq index idx)
(when slot
(collect-slot slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
+ (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 () (,@slots)
- ,@(and documentation `((:documentation ,documentation))))))
+ (collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message) (,@slots)
+ ,@(and documentation `((:documentation ,documentation))))))
`(progn
define-group
,message
(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)
'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
(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)))
+ 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))
: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
\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 ()
projects / cl-protobufs.git / blobdiff