X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=define-proto.lisp;h=8bb2423ef3a3c2b256ed2df4c110df0248f30597;hb=98e726d8056cbbb7c7093f6d9059cdab222e9242;hp=0ad110f47cb7384d7f9536b7c844df50f34b86e0;hpb=587fa704f9763f3f6310d74880af0600427e4a67;p=cl-protobufs.git diff --git a/define-proto.lisp b/define-proto.lisp index 0ad110f..8bb2423 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -14,7 +14,7 @@ ;;; Protocol buffer defining macros ;; Define a schema named 'name', corresponding to a .proto file of that name -(defmacro define-proto (name (&key proto-name syntax package import options) +(defmacro define-proto (name (&key proto-name syntax package import options documentation) &body messages &environment env) "Define a schema named 'name', corresponding to a .proto file of that name. 'proto-name' can be used to override the defaultly generated name. @@ -50,7 +50,7 @@ (collect-svc model))))) ;;--- This should warn if the old one isn't upgradable to the new one (let ((vname (fintern "*~A*" name)) - (pname (or proto-name (proto-class-name name))) + (pname (or proto-name (class-name->proto name))) (cname name) (options (loop for (key val) on options by #'cddr collect `(make-instance 'protobuf-option @@ -68,14 +68,15 @@ :options (list ,@options) :enums (list ,@enums) :messages (list ,@msgs) - :services (list ,@svcs)))) + :services (list ,@svcs) + :documentation ,documentation))) (setq ,vname protobuf) (setf (gethash ',pname *all-protobufs*) protobuf) (setf (gethash ',cname *all-protobufs*) protobuf) protobuf))))) ;; Define an enum type named 'name' and a Lisp 'deftype' -(defmacro define-enum (name (&key proto-name conc-name) &body values) +(defmacro define-enum (name (&key proto-name conc-name options documentation) &body values) "Define an enum type named 'name' and a Lisp 'deftype'. 'proto-name' can be used to override the defaultly generated name. The body consists of the enum values in the form (name &key index)." @@ -90,20 +91,27 @@ (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name)))) (collect-val val-name) (collect-eval `(make-instance 'protobuf-enum-value - :name ,(proto-enum-name enum-name) + :name ,(enum-name->proto enum-name) :index ,idx :value ,val-name))))) (collect-form `(deftype ,name () '(member ,@vals))) - `(progn - define-enum - (make-instance 'protobuf-enum - :name ,(or proto-name (proto-class-name name)) - :class ',name - :values (list ,@evals)) - ,forms))) + (let ((options (loop for (key val) on options by #'cddr + collect `(make-instance 'protobuf-option + :name ,key + :value ,val)))) + `(progn + define-enum + (make-instance 'protobuf-enum + :name ,(or proto-name (class-name->proto name)) + :class ',name + :options (list ,@options) + :values (list ,@evals) + :documentation ,documentation) + ,forms)))) ;; Define a message named 'name' and a Lisp 'defclass' -(defmacro define-message (name (&key proto-name conc-name) &body fields &environment env) +(defmacro define-message (name (&key proto-name conc-name options documentation) + &body fields &environment env) "Define a message named 'name' and a Lisp 'defclass'. 'proto-name' can be used to override the defaultly generated name. The body consists of fields, or 'define-enum' or 'define-message' forms. @@ -114,6 +122,7 @@ (slots collect-slot) (forms collect-form)) (let ((index 0)) + (declare (type fixnum index)) (dolist (fld fields) (case (car fld) ((define-enum define-message define-extension) @@ -130,9 +139,12 @@ ((define-extension) (collect-msg model))))) (otherwise + (when (i= index 18999) ;skip over the restricted range + (setq index 19999)) (destructuring-bind (slot &key type default) fld - (let* ((idx (if (listp slot) (second slot) (incf index))) + (let* ((idx (if (listp slot) (second slot) (iincf index))) (slot (if (listp slot) (first slot) slot)) + (reqd (clos-type-to-protobuf-required type)) (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot)) (symbol-package slot)))) (multiple-value-bind (ptype pclass) @@ -142,25 +154,32 @@ :initarg ,(kintern (symbol-name slot)) ,@(and default (list :initform default)))) (collect-field `(make-instance 'protobuf-field - :name ,(proto-field-name slot) + :name ,(slot-name->proto slot) :type ,ptype :class ',pclass - :required ,(clos-type-to-protobuf-required type) + :required ,reqd :index ,idx :value ',slot :default ,(and default (format nil "~A" default)) - :packed ,(packed-type-p pclass)))))))))) + :packed ,(and (eq reqd :repeated) + (packed-type-p pclass))))))))))) (collect-form `(defclass ,name () (,@slots))) - `(progn - define-message - (make-instance 'protobuf-message - :name ,(or proto-name (proto-class-name name)) - :class ',name - :conc-name ,(and conc-name (string conc-name)) - :enums (list ,@enums) - :messages (list ,@msgs) - :fields (list ,@flds)) - ,forms))) + (let ((options (loop for (key val) on options by #'cddr + collect `(make-instance 'protobuf-option + :name ,key + :value ,val)))) + `(progn + define-message + (make-instance 'protobuf-message + :name ,(or proto-name (class-name->proto name)) + :class ',name + :conc-name ,(and conc-name (string conc-name)) + :options (list ,@options) + :enums (list ,@enums) + :messages (list ,@msgs) + :fields (list ,@flds) + :documentation ,documentation) + ,forms)))) (defmacro define-extension (from to) "Define an extension range within a message. @@ -173,27 +192,39 @@ ())) ;; Define a service named 'name' and a Lisp 'defun' -(defmacro define-service (name (&key proto-name) &body rpc-specs) +(defmacro define-service (name (&key proto-name options documentation) &body rpc-specs) "Define a service named 'name' and a Lisp 'defun'. 'proto-name' can be used to override the defaultly generated name. The body consists of a set of RPC specs of the form (name input-type output-type)." - (with-collectors ((rpcs collect-rpc)) + (with-collectors ((rpcs collect-rpc) + (forms collect-form)) (dolist (rpc rpc-specs) - (destructuring-bind (name input-type output-type &key options) rpc + (destructuring-bind (name input-class output-class &key options) rpc (let ((options (loop for (key val) on options by #'cddr collect `(make-instance 'protobuf-option :name ,key :value ,val)))) (collect-rpc `(make-instance 'protobuf-rpc - :name ,(proto-class-name name) + :name ,(class-name->proto name) :class ',name - :input-type ,(and input-type (proto-class-name input-type)) - :output-type ,(and output-type (proto-class-name output-type)) - :options (list ,@options)))))) - `(progn - define-service - (make-instance 'protobuf-service - :name ,(or proto-name (proto-class-name name)) - :class ',name - :rpcs (list ,@rpcs)) - ()))) ;---*** DEFINE LISP STUB HERE + :input-type ,(and input-class (class-name->proto input-class)) + :input-class ',input-class + :output-type ,(and output-class (class-name->proto output-class)) + :output-class ',output-class + :options (list ,@options))) + ;;--- Is this really all we need as the stub for the RPC? + (collect-form `(defgeneric ,name (,@(and input-class (list input-class))) + (declare (values ,output-class))))))) + (let ((options (loop for (key val) on options by #'cddr + collect `(make-instance 'protobuf-option + :name ,key + :value ,val)))) + `(progn + define-service + (make-instance 'protobuf-service + :name ,(or proto-name (class-name->proto name)) + :class ',name + :options (list ,@options) + :rpcs (list ,@rpcs) + :documentation ,documentation) + ,forms))))