;;; ;;;
;;; 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
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
;; Only now can we bind *protobuf* to the new message
(*protobuf* message))
(with-collectors ((slots collect-slot)
- (forms collect-form))
+ (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
(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-form `(deftype ,type () ',alias-for)))
+ (collect-type-form `(deftype ,type () ',alias-for)))
;; If no alias, define the class now
- (collect-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
((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@type-forms
,@forms))))))
(defun conc-name-for-type (type conc-name)
'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))
+ 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)))
:class (proto-class message)
:name (proto-name message)
:qualified-name (proto-qualified-name message)
- :parent (proto-parent message)
+ :parent *protobuf*
:alias-for alias-for
:conc-name conc-name
:enums (copy-list (proto-enums 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*)))
;; Only now can we bind *protobuf* to the (group) message
(*protobuf* message))
(with-collectors ((slots collect-slot)
- (forms collect-form))
+ (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
(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-form `(deftype ,type () ',alias-for)))
+ (collect-type-form `(deftype ,type () ',alias-for)))
;; If no alias, define the class now
- (collect-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
((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@type-forms
,@forms))
,mfield
,mslot))))
(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)))
- (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))
: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 ()
projects / cl-protobufs.git / blobdiff