mirror of
https://gitlab.com/eql/lqml.git
synced 2025-12-06 10:31:34 -08:00
1621 lines
82 KiB
Common Lisp
1621 lines
82 KiB
Common Lisp
;;; Copyright 2012-2020 Google LLC
|
|
;;;
|
|
;;; Use of this source code is governed by an MIT-style
|
|
;;; license that can be found in the LICENSE file or at
|
|
;;; https://opensource.org/licenses/MIT.
|
|
|
|
(in-package #:cl-protobufs.implementation)
|
|
|
|
|
|
;;; Protocol buffer defining macros
|
|
|
|
|
|
#|
|
|
Notes on macroexpansion:
|
|
|
|
The lisp generated proto file should look like:
|
|
|
|
-------------------------------
|
|
|
|
;; In a package named "cl-protobufs.<the-proto-package-name>"
|
|
;; With a local-nickname pi for cl-protobufs.implementation
|
|
|
|
(pi:define-message color-wheel1 ()
|
|
;; Nested messages.
|
|
(pi:define-message color-wheel1.metadata1 ()
|
|
;; Fields.
|
|
(author :index 1 :type cl:string :label (:optional) :typename "string")
|
|
(revision :index 2 :type cl:string :label (:optional) :typename "string")
|
|
(date :index 3 :type cl:string :label (:optional) :typename "string"))
|
|
;; Fields.
|
|
(name :index 1 :type cl:string :label (:required) :typename "string")
|
|
(colors :index 2 :type (list-of color1) :label (:repeated :list)
|
|
:typename "Color1")
|
|
(metadata :index 3 :type (cl:or cl:null color-wheel1.metadata1)
|
|
:label (:optional) :typename "Metadata1"))
|
|
|
|
(cl:eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(pi:add-file-descriptor #P"third_party/lisp/cl_protobufs/tests/serialization.proto"
|
|
pi::*file-descriptors*))
|
|
|
|
(export ...)
|
|
-------------------------------
|
|
|
|
The define-schema form stores the file-descriptor for the current file in
|
|
*current-file-descriptor*. The file-descriptor holds the protobuf-service
|
|
objects that are generated by the define-service macro.
|
|
|
|
TODO(jgodbout): Remove all schema.
|
|
|
|
Next we get into the define-* macro's.
|
|
|
|
The possible top level define macros are:
|
|
- define-enum
|
|
- define-message
|
|
- define-extend
|
|
- define-service
|
|
|
|
Inside of those macros there may also be define-* forms:
|
|
- define-enum
|
|
- define-message
|
|
- define-extension
|
|
- define-extend
|
|
- define-service
|
|
- define-map
|
|
- define-oneof
|
|
|
|
The most common define-* forms are those that define messages, which generate
|
|
MESSAGE-DESCRIPTOR classes and create the message structures that hold
|
|
data. These are:
|
|
- define-message
|
|
- define-extend
|
|
|
|
DEFINE-ENUM:
|
|
|
|
The define-enum macro creates a ENUM-DESCRIPTOR meta-object, as well as methods
|
|
to access the default value, and convert from the enum keyword to the numerical
|
|
value and back.
|
|
|
|
DEFINE-EXTENSION:
|
|
|
|
Creates an EXTENSION-DESCRIPTOR and stores it in the containing message. This
|
|
descriptor simply defines the allowed range of indices for extending the
|
|
message.
|
|
|
|
DEFINE-EXTEND:
|
|
|
|
The define-extend macro creates a PROTOBUF-MESSAGE meta-object that overrides a
|
|
PROTOBUF-MESSAGE meta-object created in define-message. The new meta-object
|
|
is identical to the original but with extra fields.
|
|
|
|
We return forms to create this meta-object as well as accessors and
|
|
setters for the new fields.
|
|
|
|
DEFINE-MESSAGE:
|
|
|
|
The define-message macro works much the same way. It takes the type (message
|
|
name) and a list of sub-elements which may include define-message,
|
|
define-extension, define-extend, define-enum, or a field which is just a
|
|
declaration of the field object in a proto.
|
|
|
|
Example: (author :index 1 :type cl:string :label (:optional) :typename "string")
|
|
|
|
First we create the PROTOBUF-MESSAGE meta-object that is defined in the
|
|
define-message lambda list and store it in *current-message-descriptor*. If we
|
|
see a define-message we recursively call the define macro to create a submessage
|
|
named:
|
|
|
|
top-level-message.submessage1.submessage2
|
|
|
|
We save the resultant forms that are output so define-message may output them
|
|
at the and of the macro-call.
|
|
|
|
If we see a define-enum, define-message, or define-extend macro
|
|
we save the resultant form to a list of forms to output.
|
|
|
|
The deprecated "group" feature is handled in the protoc plug-in by generating
|
|
both a nested message and a field that uses the nested message.
|
|
|
|
If we see a field we call process-field which creates a FIELD-DESCRIPTOR
|
|
containing details of the field and returns a form to create this meta-object.
|
|
We save the form for both output and future processing.
|
|
|
|
Next we call MAKE-STRUCTURE-CLASS-FORMS that takes the field meta-objects
|
|
and creates forms for creating defstruct form for the proto data container
|
|
that will be used in client code. This is where the accessors, setters, and has
|
|
functions are defined. It outputs all of the forms to create these objects.
|
|
|
|
Finally we output all of the created forms.
|
|
|
|
DEFINE-SERVICE:
|
|
|
|
The define-service macro creates forms that make the SERVICE-DESCRIPTOR, add it to the
|
|
PROTOBUF-SCHEMA meta-object, and create method stubs for the service implementation.
|
|
|
|
Note: Actually using services require a gRPC plugin.
|
|
|
|
DEFINE-ONEOF:
|
|
|
|
The define-oneof macro takes a body of field defintions and creates a ONEOF-DESCRIPTOR
|
|
meta-object which holds field descriptors for the fields in its body. This
|
|
ONEOF-DESCRIPTOR gets appended to the message's PROTO-ONEOFS slot. Then,
|
|
MAKE-STRUCTURE-CLASS-FORMS will use the PROTO-ONEOFS slot to create forms for accessing
|
|
the oneof and its nested fields.
|
|
|#
|
|
|
|
|
|
(defvar *current-file-descriptor* nil
|
|
"The file-descriptor for the file currently being loaded.")
|
|
|
|
(defvar *current-message-descriptor* nil
|
|
"The message-descriptor for the message or group currently being loaded.")
|
|
|
|
|
|
;;; TODO(jgodbout): remove this, we already have field-descriptor
|
|
;;; "The only reason you would ever want a field-data struct instead of a
|
|
;;; field-descriptor is when you define a slot on the object which doesn't
|
|
;;; constitute a field (i.e. the %%BOOL-VALUES and %%IS-SET vectors). So in
|
|
;;; that sense, the name field-data is quite bad." --bkuehnert
|
|
(defstruct field-data
|
|
"Keep field metadata for making the structure object."
|
|
(internal-slot-name nil :type symbol)
|
|
(external-slot-name nil :type symbol)
|
|
(container nil :type (member nil :vector :list))
|
|
(accessor nil)
|
|
(type nil)
|
|
(kind nil)
|
|
(initarg nil)
|
|
(initform nil))
|
|
|
|
(defun validate-imports (file-descriptor imports)
|
|
"Validates that all of the IMPORTS (a list of file names) have
|
|
already been loaded. FILE-DESCRIPTOR is the descriptor of the
|
|
file doing the importing."
|
|
(dolist (import (reverse imports))
|
|
(let* ((imported (find-file-descriptor (if (stringp import) (pathname import) import))))
|
|
(unless imported
|
|
(protobuf-error "Could not find file ~S imported by ~S" import file-descriptor)))))
|
|
|
|
(defun define-schema (type &key name syntax edition package import
|
|
optimize options)
|
|
"Define a schema named TYPE, corresponding to a .proto file of that name.
|
|
NAME can be used to override the defaultly generated Protobufs name.
|
|
SYNTAX, EDITION, and PACKAGE are as they would be in a .proto file.
|
|
IMPORT is a list of pathname strings to be imported.
|
|
OPTIMIZE can be either :space (the default) or :speed; if it is :speed, the
|
|
serialization code will be much faster, but much less compact.
|
|
OPTIONS is a property list, i.e., (\"key1\" \"val1\" \"key2\" \"val2\" ...)."
|
|
(let* ((name (or name (class-name->proto type)))
|
|
(package (and package (if (stringp package)
|
|
package
|
|
(string-downcase (string package)))))
|
|
(options (remove-options
|
|
(loop for (key val) on options by #'cddr
|
|
collect (make-option
|
|
(if (symbolp key)
|
|
(slot-name->proto key)
|
|
key)
|
|
val))
|
|
"optimize_for"))
|
|
(imports (if (listp import) import (list import)))
|
|
(descriptor (make-instance
|
|
'file-descriptor
|
|
:class type
|
|
:name name
|
|
;; CCL requires syntax to be OR'd with :proto2, :proto3, or :editions
|
|
;; in case syntax is NIL.
|
|
:syntax (or syntax :proto2 :proto3 :editions)
|
|
:edition edition
|
|
:package package
|
|
:imports imports
|
|
:options (if optimize
|
|
(append options
|
|
(list (make-option
|
|
"optimize_for"
|
|
(if (eq optimize :speed)
|
|
"SPEED"
|
|
"CODE_SIZE")
|
|
'symbol)))
|
|
options))))
|
|
(record-file-descriptor descriptor)
|
|
(setf *current-file-descriptor* descriptor)
|
|
(validate-imports descriptor imports)))
|
|
|
|
(defgeneric enum-int-to-keyword (enum-type integer)
|
|
(:documentation
|
|
"Converts INTEGER to the corresponding enum keyword. If there are multiple
|
|
keywords assigned to the same value (i.e., allow_alias = true in the enum
|
|
source) then the first one is returned. ENUM-TYPE is the enum type name.
|
|
If no enum exists for the specified integer return nil."))
|
|
|
|
(defgeneric enum-keyword-to-int (enum-type keyword)
|
|
(:documentation
|
|
"Converts a KEYWORD to its corresponding integer value. ENUM-TYPE is the
|
|
enum-type name."))
|
|
|
|
(defun make-enum-conversion-forms (type open-type value-descriptors)
|
|
"Generates forms for enum <-> integer conversion functions. TYPE is the enum
|
|
type name. OPEN-TYPE is a type including the possibility of unknown enum keywords
|
|
as well as type. VALUE-DESCRIPTORS is a list of enum-value-descriptor objects."
|
|
(let ((key2int (fintern "~A-KEYWORD-TO-INT" type))
|
|
(int2key (fintern "~A-INT-TO-KEYWORD" type)))
|
|
`(progn
|
|
(defun ,key2int (enum)
|
|
(declare (type ,open-type enum))
|
|
(let ((int (case enum
|
|
,@(loop for desc in value-descriptors
|
|
collect `(,(enum-value-descriptor-name desc)
|
|
,(enum-value-descriptor-value desc)))
|
|
(t (parse-integer (subseq (symbol-name enum)
|
|
+%undefined--length+)
|
|
:junk-allowed t)))))
|
|
int))
|
|
|
|
(defun ,int2key (numeral)
|
|
(declare (type int32 numeral))
|
|
(the (or null ,type)
|
|
(let ((key (case numeral
|
|
,@(loop with mapped = (make-hash-table)
|
|
for desc in value-descriptors
|
|
for int = (enum-value-descriptor-value desc)
|
|
for already-set-p = (gethash int mapped)
|
|
do (setf (gethash int mapped) t)
|
|
unless already-set-p
|
|
collect `(,int ,(enum-value-descriptor-name desc))))))
|
|
key)))
|
|
|
|
(setf (get ',type 'enum-int-to-keyword) ',int2key)
|
|
(setf (get ',type 'enum-keyword-to-int) ',key2int)
|
|
|
|
(defmethod cl-protobufs:enum-keyword-to-int
|
|
((e (eql ',type)) keyword)
|
|
(,key2int keyword))
|
|
(defmethod cl-protobufs:enum-int-to-keyword
|
|
((e (eql ',type)) numeral)
|
|
(,int2key numeral)))))
|
|
|
|
(defgeneric enum-default-value (enum-type)
|
|
(:documentation
|
|
"Get the default enum value for ENUM-TYPE"))
|
|
|
|
(defmethod enum-default-value (enum-type)
|
|
"If no default enum value function can be found for a specific ENUM-TYPE
|
|
return nil."
|
|
nil)
|
|
|
|
(defun make-enum-constant-forms (type enum-values)
|
|
"Generates forms for defining a constant for each enum value in ENUM-VALUES.
|
|
TYPE is the enum type name. ENUM-VALUES is a list of ENUM-VALUE-DESCRIPTORs.
|
|
|
|
Constant names are in the form of +<message_name>.<value_name>+ when the enum is defined in a
|
|
message, and of +<value_name>+ when the enum is defined at top-level."
|
|
(let* ((enum-name (symbol-name type))
|
|
(dot (position #\. enum-name :test #'char= :from-end t))
|
|
;; Use C/C++ enum scope.
|
|
(scope (and dot (subseq enum-name 0 dot)))
|
|
(constants
|
|
(loop for v in enum-values
|
|
for c = (fintern "+~@[~A.~]~A+" scope (enum-value-descriptor-name v))
|
|
collect `(defconstant ,c ,(enum-value-descriptor-value v)))))
|
|
`(progn
|
|
,@constants
|
|
(export ',(mapcar #'second constants)))))
|
|
|
|
(defconstant +%undefined--length+ 11
|
|
"The length of %undefined- which is used frequently below")
|
|
|
|
(defun keyword-contains-%undefined-int-p (enum-keyword)
|
|
"An unknown ENUM-KEYWORD will be compiled as :%undefined-{integer} so our type
|
|
predicate must check that."
|
|
(when (keywordp enum-keyword)
|
|
(let ((keyword-name (symbol-name enum-keyword)))
|
|
(and (> (length keyword-name) +%undefined--length+)
|
|
(starts-with keyword-name "%UNDEFINED-")
|
|
(parse-integer (subseq keyword-name +%undefined--length+) :junk-allowed t)))))
|
|
|
|
(defun enum-open-type (type)
|
|
"We want the deftype of an enum TYPE to be a strict set of the keywords,
|
|
but we want an internal version for the case where we deserialized an unknown
|
|
(newer) version of hte enum with an unknown field."
|
|
(intern (format nil "%%%%~a" type)
|
|
(symbol-package type)))
|
|
|
|
(defmacro define-enum (type (&key name) &body values)
|
|
"Define a Lisp type given the data for a protobuf enum type.
|
|
Also generates conversion functions between enum values and integers:
|
|
<enum_name>-keyword-to-int and <enum_name>-int-to-keyword. Both
|
|
accept an optional default value argument.
|
|
|
|
Parameters:
|
|
TYPE: The name of the type.
|
|
NAME: Override for the protobuf enum type name.
|
|
VALUES: The possible values for the enum in the form (name :index value)."
|
|
(let ((name (or name (class-name->proto type)))
|
|
(open-type (enum-open-type type)))
|
|
(with-collectors ((names collect-name) ; keyword symbols
|
|
(forms collect-form)
|
|
(value-descriptors collect-value-descriptor))
|
|
;; The middle value is :index, useful for readability of generated code...
|
|
;; (Except that the value is not actually an index, nor is the slot called index anymore.)
|
|
(loop for (name nil value) in values do
|
|
(let* ((val-desc (make-enum-value-descriptor :value value :name name)))
|
|
(collect-name name)
|
|
(collect-value-descriptor val-desc)))
|
|
(let ((enum (make-enum-descriptor :class type
|
|
:name name
|
|
:values value-descriptors)))
|
|
(collect-form `(deftype ,open-type ()
|
|
'(or (member ,@names)
|
|
(satisfies keyword-contains-%undefined-int-p))))
|
|
(collect-form `(deftype ,type () '(member ,@names)))
|
|
(collect-form (make-enum-conversion-forms type open-type value-descriptors))
|
|
(collect-form (make-enum-constant-forms type value-descriptors))
|
|
;; The default value is the keyword associated with the first element.
|
|
(collect-form `(defmethod enum-default-value ((e (eql ',type)))
|
|
,(enum-value-descriptor-name (car value-descriptors))))
|
|
(collect-form `(record-protobuf-object ',type ,enum :enum))
|
|
(collect-form `(export '(,open-type)))
|
|
;; Register it by the full symbol name.
|
|
(record-protobuf-object type enum :enum))
|
|
`(progn ,@forms))))
|
|
|
|
(defmacro define-map (field-name &key key-type value-type json-name index
|
|
value-kind val-default)
|
|
"Define a Lisp type given the data for a protobuf map type.
|
|
|
|
Parameters:
|
|
FIELD-NAME: Lisp name of the field containing this map.
|
|
KEY-TYPE: Lisp type of the map's keys.
|
|
VALUE-TYPE: Lisp type of the map's values.
|
|
JSON-NAME: String to use for the map field when reading/writing JSON.
|
|
Either the value of the json_name field option or derived from the
|
|
field name.
|
|
VALUE-KIND: Category of the value type: :scalar, :message, :enum, etc.
|
|
INDEX: Message field number of this map type.
|
|
VAL-DEFAULT: Default value for the map entries, or nil to use $empty-default."
|
|
(assert json-name)
|
|
(assert value-kind)
|
|
(check-type index integer)
|
|
(let* ((internal-slot-name (fintern "%~A" field-name))
|
|
(qual-name (make-qualified-name *current-message-descriptor*
|
|
(slot-name->proto field-name)))
|
|
(class (fintern (uncamel-case qual-name)))
|
|
(mdata (make-field-data
|
|
:internal-slot-name internal-slot-name
|
|
:external-slot-name field-name
|
|
:type 'hash-table
|
|
:initform (if (eql key-type 'cl:string)
|
|
'(make-hash-table :test #'equal)
|
|
'(make-hash-table :test #'eq))
|
|
:accessor field-name))
|
|
(mfield (make-instance 'field-descriptor
|
|
:name (slot-name->proto field-name)
|
|
:class class
|
|
:qualified-name qual-name
|
|
:label :optional
|
|
:index index
|
|
:internal-field-name internal-slot-name
|
|
:external-field-name field-name
|
|
:json-name json-name
|
|
:type 'cl:hash-table
|
|
:default (or val-default
|
|
$empty-default)
|
|
:kind :map
|
|
:field-offset nil))
|
|
(map-desc (make-map-descriptor :key-type key-type
|
|
:value-type value-type
|
|
:value-kind value-kind)))
|
|
(record-protobuf-object class map-desc :map)
|
|
`((record-protobuf-object ',class ,map-desc :map)
|
|
,mfield
|
|
,mdata)))
|
|
|
|
(defmacro define-oneof (name (&key synthetic-p) &body fields)
|
|
"Creates a oneof descriptor and the defining forms for its fields.
|
|
|
|
Parameters:
|
|
NAME: The name of the oneof.
|
|
SYNTHETIC-P: If true, this oneof is automatically generated by protoc, in
|
|
which case the special oneof accessors should not be created.
|
|
FIELDS: Field as output by protoc."
|
|
(let* ((internal-name (fintern "%~A" name))
|
|
(field-descriptors (make-array (length fields))))
|
|
(loop for field in fields
|
|
for oneof-offset from 0
|
|
do
|
|
;; TODO(cgay): this doesn't currently handle groups. If we want to
|
|
;; support this we need to handle define-message and fields with :kind
|
|
;; :group here.
|
|
(destructuring-bind (slot &key type name (default nil default-p)
|
|
lazy json-name index kind &allow-other-keys)
|
|
field
|
|
(assert json-name)
|
|
(assert index)
|
|
(let ((default (if default-p default $empty-default)))
|
|
(setf (aref field-descriptors oneof-offset)
|
|
(make-instance 'field-descriptor
|
|
:name (or name (slot-name->proto slot))
|
|
:type type
|
|
:kind kind
|
|
:class type
|
|
:qualified-name (make-qualified-name
|
|
*current-message-descriptor*
|
|
(or name (slot-name->proto slot)))
|
|
:label :optional
|
|
:index index
|
|
;; Oneof fields don't have a bit in the %%is-set vector, as field
|
|
;; presence is tracked via the SET-FIELD slot of the oneof struct.
|
|
:field-offset nil
|
|
:internal-field-name internal-name
|
|
:external-field-name slot
|
|
:json-name json-name
|
|
:oneof-offset oneof-offset
|
|
:default default
|
|
:lazy (and lazy t))))))
|
|
`(progn
|
|
,(make-oneof-descriptor :internal-name internal-name
|
|
:external-name name
|
|
:synthetic-p (and synthetic-p t)
|
|
:fields field-descriptors))))
|
|
|
|
(defun-inline proto-%%bytes (obj)
|
|
"Returns the %%bytes field of the proto object OBJ."
|
|
(slot-value obj '%%bytes))
|
|
|
|
(defun-inline (setf proto-%%bytes) (new-value obj)
|
|
"Sets the %bytes field of the proto object OBJ with NEW-VALUE."
|
|
(setf (slot-value obj '%%bytes) new-value))
|
|
|
|
(defstruct field-accessors
|
|
"Structure containing the get, set, and has functions
|
|
for a proto-message field."
|
|
(get nil :type symbol)
|
|
(set nil :type list)
|
|
(has nil :type symbol)
|
|
(clear nil :type symbol))
|
|
|
|
(defun set-field-accessor-functions (message-name field-name)
|
|
"Set the get, set, and has functions for a proto field on a field's symbol p-list.
|
|
Parameters:
|
|
MESSAGE-NAME: The symbol name of the protobuf message containing the field.
|
|
FIELD-NAME: The symbol name for the field."
|
|
(setf (get field-name message-name)
|
|
(make-field-accessors
|
|
:get (proto-slot-function-name message-name field-name :get)
|
|
:set `(setf ,(proto-slot-function-name message-name field-name :get))
|
|
:has (proto-slot-function-name message-name field-name :internal-has)
|
|
:clear (proto-slot-function-name message-name field-name :clear))))
|
|
|
|
(defun make-common-forms-for-structure-class (proto-type public-slot-name slot-name field)
|
|
"Create the common forms needed for all message fields: has, is-set, clear, set.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp type name of the proto message.
|
|
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix).
|
|
SLOT-NAME: Slot name for the field (with the #\% prefix).
|
|
FIELD: The class object field definition of the field."
|
|
(let ((public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
|
|
(is-set-accessor (fintern "~A-%%IS-SET" proto-type))
|
|
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
|
|
(internal-has-function-name
|
|
(proto-slot-function-name proto-type public-slot-name :internal-has))
|
|
(external-has-function-name
|
|
(proto-slot-function-name proto-type public-slot-name :has))
|
|
(default-form (get-default-form (proto-type field)
|
|
(proto-default field)
|
|
(proto-container field)
|
|
(proto-type field)))
|
|
(index (proto-field-offset field))
|
|
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear))
|
|
(bool-index (proto-bool-index field))
|
|
(bit-field-name (fintern "~A-%%BOOL-VALUES" proto-type))
|
|
(field-type (cond ((eq (proto-container field) :vector)
|
|
`(cl-protobufs:vector-of ,(proto-type field)))
|
|
((eq (proto-container field) :list)
|
|
`(cl-protobufs:list-of ,(proto-type field)))
|
|
(t (proto-type field)))))
|
|
;; If index is nil, then this field does not have a reserved bit in the %%is-set vector.
|
|
;; This means that the field is proto3-style optional, so checking for field presence must
|
|
;; be done by checking if the bound value is default.
|
|
|
|
(with-gensyms (obj new-value cur-value)
|
|
`(
|
|
(defun-inline (setf ,public-accessor-name) (,new-value ,obj)
|
|
(declare (type ,field-type ,new-value))
|
|
,(when index
|
|
`(setf (bit (,is-set-accessor ,obj) ,index) 1))
|
|
,(if bool-index
|
|
`(setf (bit (,bit-field-name ,obj) ,bool-index)
|
|
(if ,new-value 1 0))
|
|
`(setf (,hidden-accessor-name ,obj) ,new-value)))
|
|
|
|
;; For proto3-style optional fields, the has-* function is repurposed. It now answers the
|
|
;; question: "Is this field set to the default value?". This is done so that the optimized
|
|
;; serializer can use the has-* function to check if an optional field should be serialized.
|
|
(defun-inline ,internal-has-function-name (,obj)
|
|
,(if index
|
|
`(= (bit (,is-set-accessor ,obj) ,index) 1)
|
|
`(let ((,cur-value ,(if bool-index
|
|
`(plusp (bit (,bit-field-name ,obj) ,bool-index))
|
|
`(,hidden-accessor-name ,obj))))
|
|
,(case (proto-container field)
|
|
(:vector `(not (= (length ,cur-value) 0)))
|
|
(:list `(and ,cur-value t))
|
|
(t (case (proto-type field)
|
|
((byte-vector cl:string) `(> (length ,cur-value) 0))
|
|
((cl:double-float cl:float) `(not (= ,cur-value ,default-form)))
|
|
(cl:hash-table `(> (hash-table-count ,cur-value) 0))
|
|
;; Otherwise, the type is integral. EQ suffices to check equality.
|
|
(t `(not (eq ,cur-value ,default-form)))))))))
|
|
|
|
;; has-* functions are not exported for proto3-style optional fields. They are only for
|
|
;; internal usage.
|
|
,@(unless (eq (proto-syntax *current-file-descriptor*) :proto3)
|
|
`((defun-inline ,external-has-function-name (,obj)
|
|
(,internal-has-function-name ,obj))
|
|
(export '(,external-has-function-name))))
|
|
|
|
;; Clear function
|
|
;; Map type clear functions are created in make-map-accessor-forms.
|
|
;; todo(benkuehnert): rewrite map types/definers so that this isn't necessary
|
|
,@(unless (eq (proto-kind field) :map)
|
|
`((defun-inline ,clear-function-name (,obj)
|
|
,(when index
|
|
`(setf (bit (,is-set-accessor ,obj) ,index) 0))
|
|
,(if bool-index
|
|
`(setf (bit (,bit-field-name ,obj) ,bool-index)
|
|
,(if default-form 1 0))
|
|
`(setf (,hidden-accessor-name ,obj) ,default-form)))))
|
|
|
|
;; Create defmethods to allow for getting/setting compatibly
|
|
;; with the standard-classes.
|
|
(defmethod ,public-slot-name ((,obj ,proto-type))
|
|
(,public-accessor-name ,obj))
|
|
|
|
(defmethod (setf ,public-slot-name) (,new-value (,obj ,proto-type))
|
|
(setf (,public-accessor-name ,obj) ,new-value))
|
|
|
|
(set-field-accessor-functions ',proto-type ',public-slot-name)
|
|
|
|
,(unless (eq (proto-kind field) :map)
|
|
`(export '(,clear-function-name)))
|
|
|
|
(export '(,public-accessor-name))))))
|
|
|
|
(defun make-repeated-field-accessors (proto-type field)
|
|
"Make and return forms that define functions that accesses a proto
|
|
repeated slot.
|
|
|
|
A push function pushes onto the front for a list repeated field,
|
|
and onto the back for a vector repeated field. It returns the element added.
|
|
|
|
A length function returns a fixnum of the number of the elements in the
|
|
repeated field.
|
|
|
|
An nth function returns the nth element in a repeated field,
|
|
or signals an out of bounds error.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp name of the containing message.
|
|
FIELD: The field we are making the functions for."
|
|
(let* ((public-slot-name (proto-external-field-name field))
|
|
(public-accessor-name (proto-slot-function-name
|
|
proto-type public-slot-name :get))
|
|
(push-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :push))
|
|
(push-method-name (fintern "PUSH-~A" public-slot-name))
|
|
(length-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :length-OF))
|
|
(length-method-name (fintern "LENGTH-OF-~A" public-slot-name))
|
|
(nth-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :nth))
|
|
(nth-method-name (fintern "NTH-~A" public-slot-name))
|
|
(field-type (proto-type field)))
|
|
(with-gensyms (obj element n)
|
|
`((defun ,push-function-name (,element ,obj)
|
|
(declare (type ,proto-type ,obj)
|
|
(type ,field-type ,element))
|
|
,(if (eq (proto-container field) :vector)
|
|
`(progn (vector-push-extend ,element
|
|
(,public-accessor-name ,obj))
|
|
,element)
|
|
`(push ,element (,public-accessor-name ,obj))))
|
|
(defun ,length-function-name (,obj)
|
|
(declare (type ,proto-type ,obj))
|
|
(the fixnum
|
|
(length (,public-accessor-name ,obj))))
|
|
|
|
(defun ,nth-function-name (,n ,obj)
|
|
(declare (type ,proto-type ,obj)
|
|
(type fixnum ,n))
|
|
(the ,field-type
|
|
(let ((length (length (,public-accessor-name ,obj))))
|
|
(when (i< length ,n)
|
|
(protobuf-error "Repeated field ~S is length ~D but element ~D was requested."
|
|
',public-slot-name length ,n))
|
|
,(if (eq (proto-container field) :vector)
|
|
`(aref (,public-accessor-name ,obj) ,n)
|
|
`(nth ,n (,public-accessor-name ,obj))))))
|
|
|
|
(defmethod ,push-method-name (,element (,obj ,proto-type))
|
|
(,push-function-name ,element ,obj))
|
|
(defmethod ,length-method-name ((,obj ,proto-type))
|
|
(,length-function-name ,obj))
|
|
(defmethod ,nth-method-name ((,n integer) (,obj ,proto-type))
|
|
(,nth-function-name ,n ,obj))
|
|
|
|
(export '(,push-method-name ,push-function-name
|
|
,nth-function-name ,nth-method-name
|
|
,length-function-name ,length-method-name))))))
|
|
|
|
(defun make-oneof-accessor-forms (proto-type oneof)
|
|
"Make and return forms that define accessor functions for a oneof and its fields.
|
|
|
|
Paramters:
|
|
PROTO-TYPE: The lisp name of the containing message of this oneof.
|
|
ONEOF: The oneof-descriptor of the oneof to make accessors for."
|
|
(let* ((public-slot-name (oneof-descriptor-external-name oneof))
|
|
(hidden-slot-name (oneof-descriptor-internal-name oneof))
|
|
(hidden-accessor-name (fintern "~A-~A" proto-type hidden-slot-name))
|
|
(case-function-name (proto-slot-function-name proto-type public-slot-name :case))
|
|
(internal-has-function-name
|
|
(proto-slot-function-name proto-type public-slot-name :internal-has))
|
|
(external-has-function-name
|
|
(proto-slot-function-name proto-type public-slot-name :has))
|
|
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear)))
|
|
(with-gensyms (obj)
|
|
`(
|
|
;; Since the oneof struct stores an integer to indicate which field is set, it is not
|
|
;; particularly useful for the user when writing code surrounding oneof types. This
|
|
;; creates a function which returns a symbol with the same name as the field which
|
|
;; is currently set. If the field is not set, this function returns nil.
|
|
(defun-inline ,case-function-name (,obj)
|
|
(ecase (oneof-set-field (,hidden-accessor-name ,obj))
|
|
,@(loop for field across (oneof-descriptor-fields oneof)
|
|
collect
|
|
`(,(proto-oneof-offset field) ',(proto-external-field-name field)))
|
|
((nil) nil)))
|
|
|
|
(defun-inline ,internal-has-function-name (,obj)
|
|
(not (eql (oneof-set-field (,hidden-accessor-name ,obj)) nil)))
|
|
(defun-inline ,external-has-function-name (,obj)
|
|
(,internal-has-function-name ,obj))
|
|
|
|
(defun-inline ,clear-function-name (,obj)
|
|
(setf (oneof-value (,hidden-accessor-name ,obj)) nil)
|
|
(setf (oneof-set-field (,hidden-accessor-name ,obj)) nil))
|
|
|
|
;; Special oneof forms are only created when ONEOF is not synthetic.
|
|
,(unless (oneof-descriptor-synthetic-p oneof)
|
|
`(export '(,case-function-name ,external-has-function-name ,clear-function-name)))
|
|
|
|
;; Fields inside of a oneof need special accessors, since they need to consult
|
|
;; with the oneof struct. This creates those special accessors for each field.
|
|
;; This mostly mirrors what happens in make-common-forms-for-structure-class
|
|
;; and make-structure-class-forms-non-lazy, but they consult the oneof struct
|
|
;; to check if they are set.
|
|
,@(loop
|
|
for field across (oneof-descriptor-fields oneof)
|
|
append
|
|
(let* ((public-slot-name (proto-external-field-name field))
|
|
(public-accessor-name (proto-slot-function-name
|
|
proto-type public-slot-name :get))
|
|
(internal-has-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :internal-has))
|
|
(external-has-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :has))
|
|
(clear-function-name (proto-slot-function-name
|
|
proto-type public-slot-name :clear))
|
|
(default-form (get-default-form (proto-type field)
|
|
(proto-default field)
|
|
(proto-container field)
|
|
(proto-kind field)))
|
|
(field-type (proto-type field))
|
|
(oneof-offset (proto-oneof-offset field)))
|
|
|
|
;; If a field isn't currently set inside of the oneof, just return its
|
|
;; default value.
|
|
(with-gensyms (obj new-value bytes field-obj)
|
|
`((defun-inline ,public-accessor-name (,obj)
|
|
(if (eq (oneof-set-field (,hidden-accessor-name ,obj))
|
|
,oneof-offset)
|
|
,(if (proto-lazy-p field)
|
|
`(let* ((,field-obj (oneof-value (,hidden-accessor-name ,obj)))
|
|
(,bytes (and ,field-obj (proto-%%bytes ,field-obj))))
|
|
(if ,bytes
|
|
(setf (oneof-value (,hidden-accessor-name ,obj))
|
|
(%deserialize ',(proto-class field)
|
|
,bytes nil nil))))
|
|
`(oneof-value (,hidden-accessor-name ,obj)))
|
|
,default-form))
|
|
|
|
(defun-inline (setf ,public-accessor-name) (,new-value ,obj)
|
|
(declare (type ,field-type ,new-value))
|
|
(setf (oneof-set-field (,hidden-accessor-name ,obj))
|
|
,oneof-offset)
|
|
(setf (oneof-value (,hidden-accessor-name ,obj)) ,new-value))
|
|
|
|
(defun-inline ,internal-has-function-name (,obj)
|
|
(eq (oneof-set-field (,hidden-accessor-name ,obj))
|
|
,oneof-offset))
|
|
(defun-inline ,external-has-function-name (,obj)
|
|
(,internal-has-function-name ,obj))
|
|
|
|
(defun-inline ,clear-function-name (,obj)
|
|
(when (,internal-has-function-name ,obj)
|
|
(setf (oneof-value (,hidden-accessor-name ,obj)) nil)
|
|
(setf (oneof-set-field (,hidden-accessor-name ,obj)) nil)))
|
|
|
|
(defmethod ,public-slot-name ((,obj ,proto-type))
|
|
(,public-accessor-name ,obj))
|
|
|
|
(defmethod (setf ,public-slot-name) (,new-value (,obj ,proto-type))
|
|
(setf (,public-accessor-name ,obj) ,new-value))
|
|
|
|
(set-field-accessor-functions ',proto-type ',public-slot-name)
|
|
|
|
(export '(,external-has-function-name
|
|
,clear-function-name
|
|
,public-accessor-name))))))))))
|
|
|
|
(defun make-map-accessor-forms (proto-type public-slot-name slot-name field)
|
|
"This creates forms that define map accessors which are type safe. Using these will
|
|
guarantee that the resulting map can be properly serialized, whereas if one modifies
|
|
the underlying map (which is accessed via the make-common-forms-for-structure-class
|
|
function) then there is no guarantee on the serialize function working properly.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp type name of the proto message.
|
|
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix).
|
|
SLOT-NAME: Slot name for the field (with the #\% prefix).
|
|
FIELD: The class object field definition of the field."
|
|
(let* ((public-accessor-name (proto-slot-function-name proto-type public-slot-name :map-get))
|
|
(public-remove-name (proto-slot-function-name proto-type public-slot-name :map-rem))
|
|
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear))
|
|
(method-accessor-name (fintern "~A-gethash" public-slot-name))
|
|
(method-remove-name (fintern "~A-remhash" public-slot-name))
|
|
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
|
|
(map-descriptor (find-map-descriptor (proto-class field)))
|
|
(key-type (proto-key-type map-descriptor))
|
|
(value-type (proto-value-type map-descriptor))
|
|
(value-kind (proto-value-kind map-descriptor))
|
|
(val-default-form
|
|
(get-default-form value-type (proto-default field) nil value-kind)))
|
|
|
|
(with-gensyms (obj new-val new-key)
|
|
`(
|
|
(defun-inline (setf ,public-accessor-name) (,new-val ,new-key ,obj)
|
|
(declare (type ,key-type ,new-key)
|
|
(type ,value-type ,new-val))
|
|
(setf (gethash ,new-key (,hidden-accessor-name ,obj)) ,new-val))
|
|
|
|
;; If the map's value type is a message, then the default value returned
|
|
;; should be nil. However, we do not want to allow the user to insert nil
|
|
;; into the map, so this binding only applies to get function.
|
|
,@(let ((val-type (if (member value-kind '(:message :group :extends))
|
|
(list 'or 'null value-type)
|
|
value-type)))
|
|
|
|
`((defun-inline ,public-accessor-name (,new-key ,obj)
|
|
(declare (type ,key-type ,new-key))
|
|
(the (values ,(if (eq value-kind :enum)
|
|
(enum-open-type val-type)
|
|
val-type)
|
|
t)
|
|
(multiple-value-bind (val flag)
|
|
(gethash ,new-key (,hidden-accessor-name ,obj))
|
|
(if flag
|
|
(values val flag)
|
|
(values ,val-default-form nil)))))))
|
|
|
|
(defun-inline ,public-remove-name (,new-key ,obj)
|
|
(declare (type ,key-type ,new-key))
|
|
(remhash ,new-key (,hidden-accessor-name ,obj)))
|
|
|
|
(defun-inline ,clear-function-name (,obj)
|
|
(clrhash (,hidden-accessor-name ,obj)))
|
|
|
|
;; These defmethods have the same functionality as the functions defined above
|
|
;; but they don't require a refernece to the message type, so using them is more
|
|
;; convenient.
|
|
(defmethod (setf ,method-accessor-name) (,new-val ,new-key (,obj ,proto-type))
|
|
(setf (,public-accessor-name ,new-key ,obj) ,new-val))
|
|
|
|
(defmethod ,method-accessor-name (,new-key (,obj ,proto-type))
|
|
(,public-accessor-name ,new-key ,obj))
|
|
|
|
(defmethod ,method-remove-name (,new-key (,obj ,proto-type))
|
|
(,public-remove-name ,new-key ,obj))
|
|
|
|
(export '(,public-accessor-name
|
|
,public-remove-name
|
|
,clear-function-name
|
|
,method-accessor-name
|
|
,method-remove-name))))))
|
|
|
|
(defun make-structure-class-forms-lazy (proto-type field public-slot-name)
|
|
"Makes forms for the lazy fields of a proto message using STRUCTURE-CLASS.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp type name of the proto message.
|
|
FIELD: The field definition for which to define accessors.
|
|
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix)."
|
|
(let* ((slot-name (proto-internal-field-name field))
|
|
(repeated (eq (proto-label field) :repeated))
|
|
(vectorp (eq :vector (proto-container field)))
|
|
(public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
|
|
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
|
|
(accessor-return-type
|
|
(cond ((eq (proto-container field) :vector)
|
|
`(cl-protobufs:vector-of ,(proto-type field)))
|
|
((eq (proto-container field) :list)
|
|
`(cl-protobufs:list-of ,(proto-type field)))
|
|
((member (proto-kind field) '(:message :group :extends))
|
|
`(or null ,(proto-type field)))
|
|
(t (proto-type field)))))
|
|
(with-gensyms (obj field-obj bytes)
|
|
`((defun-inline ,public-accessor-name (,obj)
|
|
(the
|
|
,accessor-return-type
|
|
,(if (not repeated)
|
|
`(let* ((,field-obj (,hidden-accessor-name ,obj))
|
|
(,bytes (and ,field-obj (proto-%%bytes ,field-obj))))
|
|
(if ,bytes
|
|
(setf (,hidden-accessor-name ,obj)
|
|
;; Re-create the field object by deserializing its %%bytes
|
|
;; field.
|
|
(%deserialize ',(proto-class field) ,bytes nil nil))
|
|
,field-obj))
|
|
`(let ((,field-obj (,hidden-accessor-name ,obj)))
|
|
(if (notany #'proto-%%bytes ,field-obj)
|
|
,field-obj
|
|
,(with-gensyms (maybe-deserialize field-element)
|
|
`(flet ((,maybe-deserialize (,field-element)
|
|
(let ((,bytes (proto-%%bytes ,field-element)))
|
|
(if ,bytes
|
|
;; Re-create the field object by deserializing
|
|
;; its %%bytes field.
|
|
(%deserialize ',(proto-class field) ,bytes nil nil)
|
|
,field-element))))
|
|
(setf (,hidden-accessor-name ,obj)
|
|
,(if vectorp
|
|
`(map 'vector #',maybe-deserialize
|
|
(the vector ,field-obj))
|
|
`(mapcar #',maybe-deserialize ,field-obj))))))))))
|
|
,@(make-common-forms-for-structure-class proto-type public-slot-name slot-name field)))))
|
|
|
|
(defun make-structure-class-forms-non-lazy (proto-type field public-slot-name)
|
|
"Makes forms for the non-lazy fields of a proto message.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp type name of the proto message.
|
|
FIELD: The field definition for which to define accessors.
|
|
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix)."
|
|
(let* ((slot-name (proto-internal-field-name field))
|
|
(public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
|
|
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
|
|
(bool-index (proto-bool-index field))
|
|
(bit-field-name (fintern "~A-%%BOOL-VALUES" proto-type))
|
|
(field-type (proto-type field))
|
|
(accessor-return-type
|
|
(cond ((eq (proto-container field) :vector)
|
|
`(cl-protobufs:vector-of ,field-type))
|
|
((eq (proto-container field) :list)
|
|
`(cl-protobufs:list-of ,field-type))
|
|
((member (proto-kind field) '(:message :group :extends))
|
|
`(or null ,field-type))
|
|
(t field-type))))
|
|
(with-gensyms (obj)
|
|
`((defun-inline ,public-accessor-name (,obj)
|
|
(the ,accessor-return-type
|
|
,(if bool-index
|
|
`(plusp (bit (,bit-field-name ,obj) ,bool-index))
|
|
`(,hidden-accessor-name ,obj))))
|
|
|
|
,@(make-common-forms-for-structure-class
|
|
proto-type public-slot-name slot-name field)
|
|
|
|
,@(when (proto-container field)
|
|
(make-repeated-field-accessors proto-type field))
|
|
|
|
;; Make special map forms.
|
|
,@(when (typep (find-map-descriptor (proto-class field)) 'map-descriptor)
|
|
(make-map-accessor-forms
|
|
proto-type public-slot-name slot-name field))))))
|
|
|
|
|
|
(let ((defaults (make-hash-table)))
|
|
(loop for type in '(int32 uint32 fixed32 sfixed32 sint32
|
|
int64 uint64 fixed64 sfixed64 sint64)
|
|
do (setf (gethash type defaults) 0))
|
|
|
|
(setf (gethash 'double-float defaults) 0.0d0)
|
|
(setf (gethash 'float defaults) 0.0)
|
|
(setf (gethash 'boolean defaults) nil)
|
|
(setf (gethash 'string defaults) "")
|
|
(setf (gethash 'byte-vector defaults) '(make-byte-vector 0 :adjustable t))
|
|
|
|
;; Home grown types
|
|
(setf (gethash 'cl:keyword defaults) :default-keyword)
|
|
(setf (gethash 'cl:symbol defaults) nil)
|
|
|
|
(defun get-default-form (type default container kind)
|
|
"Find the default value for a specified type.
|
|
|
|
Parameters:
|
|
TYPE: The type we want to get the default form for.
|
|
DEFAULT: A user defined default or one of nil $empty-default.
|
|
CONTAINER: If the field we're getting the default for is repeated then
|
|
the type of container to hold the repeated data in.
|
|
KIND: The kind of message this is, one of :group :message :extends
|
|
:enum :scalar."
|
|
(let ((possible-default (gethash type defaults)))
|
|
(cond
|
|
((not (member default (list $empty-default nil)))
|
|
default)
|
|
((eq container :vector)
|
|
`(make-array 0 :element-type ',type
|
|
:adjustable t
|
|
:fill-pointer 0))
|
|
((eq container :list) nil)
|
|
((member kind '(:group :message :extends))
|
|
nil)
|
|
((eq type :map)
|
|
'(make-hash-table))
|
|
((or possible-default
|
|
(eq type 'cl:boolean))
|
|
possible-default)))))
|
|
|
|
(defun make-structure-class-forms (proto-type slots non-lazy-fields lazy-fields oneofs)
|
|
"Makes the definition forms for the define-message macro.
|
|
|
|
Parameters:
|
|
PROTO-TYPE: The Lisp type name of the proto message.
|
|
SLOTS: Slot definitions created by PROCESS-FIELD.
|
|
NON-LAZY-FIELDS: Field definitions for non-lazy fields.
|
|
LAZY-FIELDS: Field definitions for lazy fields.
|
|
ONEOFS: A list of oneof descriptors for the message/group."
|
|
(let* ((public-constructor-name (fintern "MAKE-~A" proto-type))
|
|
(hidden-constructor-name (fintern "%MAKE-~A" proto-type))
|
|
(public-lazy-slot-names (mapcar #'proto-external-field-name lazy-fields))
|
|
(public-non-lazy-slot-names (mapcar #'proto-external-field-name non-lazy-fields))
|
|
(is-set-name (fintern "~A-%%IS-SET" proto-type))
|
|
(clear-is-set-name (fintern "~A.CLEAR-%%IS-SET" proto-type))
|
|
(additional-slots '(%%is-set))
|
|
(oneof-fields (loop for oneof in oneofs
|
|
append (coerce (oneof-descriptor-fields oneof) 'list))))
|
|
(with-gensyms (obj)
|
|
`(progn
|
|
;; DEFSTRUCT form.
|
|
(declaim (inline ,hidden-constructor-name))
|
|
(defstruct (,proto-type (:constructor ,hidden-constructor-name)
|
|
(:include message)
|
|
;; Yet more class->struct code we have to add,
|
|
;; todo(jgodbout):delete asap
|
|
(:predicate nil))
|
|
,@(remove nil
|
|
(append
|
|
(mapcar (lambda (slot)
|
|
(let ((name (field-data-internal-slot-name slot))
|
|
(type (field-data-type slot))
|
|
(initform (field-data-initform slot))
|
|
(container (field-data-container slot))
|
|
(kind (field-data-kind slot)))
|
|
(unless (eq type 'boolean)
|
|
`(,name ,(get-default-form type initform container kind) :type ,type))))
|
|
slots)
|
|
(mapcar (lambda (oneof)
|
|
(let ((name (oneof-descriptor-internal-name oneof)))
|
|
`(,name (make-oneof) :type oneof)))
|
|
oneofs))))
|
|
;; Define public accessors for fields.
|
|
,@(mapcan (lambda (field public-slot-name)
|
|
(make-structure-class-forms-non-lazy proto-type
|
|
field
|
|
public-slot-name))
|
|
non-lazy-fields public-non-lazy-slot-names)
|
|
,@(mapcan (lambda (field public-slot-name)
|
|
(make-structure-class-forms-lazy proto-type field public-slot-name))
|
|
lazy-fields public-lazy-slot-names)
|
|
|
|
;; Define public accessors for oneofs.
|
|
,@(mapcan (lambda (oneof)
|
|
(make-oneof-accessor-forms proto-type oneof))
|
|
oneofs)
|
|
|
|
;; Define public constructor.
|
|
(defun-inline ,public-constructor-name
|
|
(&key
|
|
,@(loop for sn in public-non-lazy-slot-names
|
|
collect `(,sn :%unset))
|
|
,@(loop for sn in public-lazy-slot-names
|
|
collect `(,sn :%unset))
|
|
,@(loop for oneof in oneofs
|
|
collect`(,(oneof-descriptor-external-name oneof) :%unset))
|
|
,@(loop for field in oneof-fields
|
|
collect `(,(proto-external-field-name field) :%unset)))
|
|
(let ((,obj (,hidden-constructor-name)))
|
|
,@(mapcan
|
|
(lambda (field)
|
|
(let* ((type (proto-type field))
|
|
(public-slot-name (proto-external-field-name field))
|
|
(set-check (if (eq type 'cl:boolean)
|
|
`(eq ,public-slot-name :%unset)
|
|
`(or (eq ,public-slot-name :%unset)
|
|
(not ,public-slot-name)))))
|
|
(let ((public-accessor-name
|
|
(proto-slot-function-name proto-type public-slot-name :get)))
|
|
`((unless ,set-check
|
|
(setf (,public-accessor-name ,obj) ,public-slot-name))))))
|
|
(append non-lazy-fields
|
|
lazy-fields
|
|
oneof-fields))
|
|
,@(mapcan
|
|
(lambda (oneof)
|
|
(let* ((public-slot-name (oneof-descriptor-external-name oneof))
|
|
(hidden-slot-name (oneof-descriptor-internal-name oneof))
|
|
(set-check `(or (eq ,public-slot-name :%unset)
|
|
(not ,public-slot-name))))
|
|
`((unless ,set-check
|
|
(setf (slot-value ,obj ',hidden-slot-name) ,public-slot-name)))))
|
|
oneofs)
|
|
,obj))
|
|
|
|
;; Define clear functions.
|
|
(defun ,clear-is-set-name (,obj)
|
|
(fill (,is-set-name ,obj) 0))
|
|
|
|
(export '(,public-constructor-name ,is-set-name))
|
|
(defmethod clear ((,obj ,proto-type))
|
|
(setf (message-%%skipped-bytes ,obj) nil)
|
|
,@(mapcan (lambda (name)
|
|
(let ((clear-name (fintern "~A.CLEAR-~A" proto-type name)))
|
|
`((,clear-name ,obj))))
|
|
(append public-non-lazy-slot-names additional-slots
|
|
(mapcar #'oneof-descriptor-external-name oneofs))))))))
|
|
|
|
(defun non-repeated-bool-field (field)
|
|
"Determine if a field given by a FIELD is a non-repeated boolean."
|
|
(and (member 'cl:boolean field)
|
|
(not (member '(:repeated :list) field :test #'equal))
|
|
(not (member '(:repeated :vector) field :test #'equal))))
|
|
|
|
(defmacro define-message (type (&key name alias-for options)
|
|
&body fields &environment env)
|
|
"Define a new protobuf message type.
|
|
|
|
Parameters:
|
|
TYPE - Symbol naming the new type.
|
|
NAME - Optional symbol used to override the defaultly generated protobuf message name.
|
|
This is supplied automatically by protoc-gen-cl-pb when TYPE cannot be accurately
|
|
converted back to a camelCase name.
|
|
ALIAS-FOR - If supplied, no Lisp struct is defined. Instead, the message is used
|
|
as an alias for a class that already exists. This feature is intended to be
|
|
used to define messages that will be serialized from existing Lisp classes;
|
|
unless you get the slot names or readers exactly right for each field,
|
|
trying to (de)serialize into a Lisp object won't work.
|
|
OPTIONS - A set of keyword/value pairs, both of which are strings.
|
|
FIELDS - Either field specs of the form (name :index n :type t ...) or
|
|
define-{message,enum,oneof,map} forms. See process-field for more info."
|
|
(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)))
|
|
(msg-desc (make-instance 'message-descriptor
|
|
:class type
|
|
:name name
|
|
:qualified-name (make-qualified-name
|
|
(or *current-message-descriptor*
|
|
*current-file-descriptor*)
|
|
name)
|
|
:alias-for alias-for
|
|
:options (remove-options options "default" "packed")))
|
|
(field-offset 0)
|
|
(*current-message-descriptor* msg-desc)
|
|
(bool-count (count-if #'non-repeated-bool-field fields))
|
|
(bool-index -1)
|
|
(bool-values (make-array bool-count :element-type 'bit :initial-element 0)))
|
|
(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)
|
|
(lazy-fields collect-lazy-field)
|
|
(non-lazy-fields collect-non-lazy-field)
|
|
(oneofs collect-oneof))
|
|
(dolist (field fields)
|
|
(case (car field)
|
|
((define-message define-extend define-enum)
|
|
(let ((result (macroexpand-1 field env)))
|
|
(assert (eq (car result) 'progn) ()
|
|
"The macroexpansion for ~S failed" field)
|
|
(map () #'collect-type-form (cdr result))))
|
|
((define-map)
|
|
(destructuring-bind (definer extra-field extra-slot)
|
|
(macroexpand-1 field env)
|
|
(collect-form definer)
|
|
(collect-slot extra-slot)
|
|
(collect-non-lazy-field extra-field)
|
|
(push extra-field (proto-fields msg-desc))))
|
|
((define-extension)
|
|
(destructuring-bind (from to) (cdr field)
|
|
(let* ((to (etypecase to
|
|
(integer to)
|
|
(symbol (if (string-equal to "MAX") +max-field-number+ to))))
|
|
(ext-desc (make-instance 'extension-descriptor
|
|
:from from
|
|
:to (if (eq to 'max) +max-field-number+ to))))
|
|
(push ext-desc (proto-extensions msg-desc)))))
|
|
((define-oneof)
|
|
(destructuring-bind (&optional progn oneof-desc)
|
|
(macroexpand-1 field env)
|
|
(assert (eq progn 'progn) ()
|
|
"The macroexpansion for ~S failed in DEFINE-MESSAGE" field)
|
|
(when oneof-desc
|
|
(push oneof-desc (proto-oneofs msg-desc))
|
|
(collect-oneof oneof-desc))))
|
|
(otherwise
|
|
;; It's a regular field. Note that groups generate both a nested
|
|
;; message and a field with :kind :group.
|
|
(multiple-value-bind (field-desc slot idx offset-p)
|
|
(process-field field :alias-for alias-for
|
|
:field-offset field-offset
|
|
:bool-index (when (non-repeated-bool-field field)
|
|
(incf bool-index))
|
|
:bool-values bool-values)
|
|
(declare (ignore idx))
|
|
(when offset-p
|
|
(incf field-offset))
|
|
(if (proto-lazy-p field-desc)
|
|
(collect-lazy-field field-desc)
|
|
(collect-non-lazy-field field-desc))
|
|
(assert (not (find-field-descriptor msg-desc (proto-index field-desc))) ()
|
|
"The field ~S overlaps with another field in ~S"
|
|
(proto-internal-field-name field-desc) (proto-class msg-desc))
|
|
(when slot
|
|
(collect-slot slot))
|
|
(push field-desc (proto-fields msg-desc))))))
|
|
;; Not required, but this will have the proto-fields serialized
|
|
;; in the order they were defined.
|
|
(setf (proto-fields msg-desc) (nreverse (proto-fields msg-desc)))
|
|
;; One extra slot for the make-message-with-bytes feature.
|
|
(collect-slot
|
|
(make-field-data
|
|
:internal-slot-name '%%bytes
|
|
:external-slot-name '%%bytes
|
|
:type '(or null (simple-array (unsigned-byte 8)))
|
|
:initarg :%%bytes
|
|
:initform nil))
|
|
|
|
(unless (= bool-index -1)
|
|
(collect-slot
|
|
(make-field-data
|
|
:internal-slot-name '%%bool-values
|
|
:external-slot-name '%%bool-values
|
|
:type `(bit-vector ,bool-count)
|
|
:initarg :%%bool-values
|
|
:container :vector
|
|
:initform `(make-array ,bool-count :element-type 'bit
|
|
:initial-contents ,bool-values))))
|
|
|
|
;; todo(jgodbout): Storing the is-set vector as N >= 1 slots of
|
|
;; type sb-ext:word rather than 1 slot as a bit-vector would reduce
|
|
;; the memory reads by 1 per slot access.
|
|
(collect-slot
|
|
(make-field-data
|
|
:internal-slot-name '%%is-set
|
|
:external-slot-name '%%is-set
|
|
:type `(bit-vector ,field-offset)
|
|
:initarg :%%is-set
|
|
:container :vector
|
|
:initform `(make-array ,field-offset
|
|
:element-type 'bit
|
|
:initial-element 0)))
|
|
(if alias-for
|
|
;; If we've got an alias, define a type that is the subtype of the Lisp class so that
|
|
;; typep and subtypep work. Unless alias-for is a type which is not yet defined (as is
|
|
;; usually the case), in which case just define a vacuous type for the message.
|
|
(unless (or (eq type alias-for) (find-class type nil))
|
|
(let* ((alias-class (find-class alias-for nil))
|
|
(alias-type (or (and alias-class (class-name alias-class))
|
|
t)))
|
|
(collect-type-form `(deftype ,type () ',alias-type))
|
|
(collect-form `(record-protobuf-object ',alias-for ,msg-desc :message))))
|
|
;; If no alias, define the class now
|
|
(collect-type-form
|
|
(make-structure-class-forms type slots non-lazy-fields lazy-fields oneofs)))
|
|
;; Register it by the full symbol name.
|
|
(record-protobuf-object type msg-desc :message)
|
|
(collect-form `(record-protobuf-object ',type ,msg-desc :message))
|
|
`(progn ,@type-forms ,@forms))))
|
|
|
|
(defmacro define-extend (type (&key name options) &body fields)
|
|
"Define an extension to the message named TYPE. See define-message for descriptions of the
|
|
NAME, OPTIONS, and FIELDS parameters."
|
|
(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-descriptor type)) ; should pass :error-p t here instead
|
|
(alias-for (and message (proto-alias-for message)))
|
|
(extends (and message
|
|
(make-instance
|
|
'message-descriptor
|
|
:class (proto-class message)
|
|
:name (proto-name message)
|
|
:qualified-name (proto-qualified-name message)
|
|
:alias-for alias-for
|
|
: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
|
|
;; Only now can we bind *current-message-descriptor* to the new extended message
|
|
(*current-message-descriptor* extends))
|
|
(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))
|
|
(loop for field in fields
|
|
with new-slot = nil
|
|
with new-field = nil
|
|
do
|
|
(assert (not (member (car field)
|
|
'(define-enum define-message define-extend define-extension)))
|
|
() "The body of ~S can only contain field and group definitions" 'define-extend)
|
|
(multiple-value-bind (field-desc slot idx)
|
|
(process-field field :alias-for alias-for)
|
|
(assert (index-within-extensions-p idx message) ()
|
|
"The index ~D is not in range for extending ~S"
|
|
idx (proto-class message))
|
|
(setf new-slot slot)
|
|
(setf new-field field-desc))
|
|
(when new-slot ; why isn't it an error for new-slot to be nil?
|
|
(let* (;; The slot name which is the %field-name
|
|
(sname (field-data-internal-slot-name new-slot))
|
|
;; The field name
|
|
(fname (field-data-external-slot-name new-slot))
|
|
(stable (fintern "~A-VALUES" sname))
|
|
(stype (field-data-type new-slot))
|
|
(reader (or (field-data-accessor new-slot)
|
|
(symbol-name sname)))
|
|
(writer (fintern "~A-~A" 'set reader))
|
|
(default (field-data-initform new-slot)))
|
|
;; 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.
|
|
(collect-form
|
|
`(without-redefinition-warnings ()
|
|
(let ((,stable (tg:make-weak-hash-table :weakness :key :test #'eq)))
|
|
,@(and reader `((defmethod ,reader ((object ,type))
|
|
(gethash object ,stable ,default))))
|
|
,@(and writer `((defmethod ,writer ((object ,type) value)
|
|
#-ccl (declare (type ,stype value))
|
|
(setf (gethash object ,stable) value))))
|
|
(defmethod get-extension ((object ,type) (slot (eql ',fname)))
|
|
(values (gethash object ,stable ,default)))
|
|
;; Set and has need to be defined for sname and fname
|
|
;; for usefulness to reader and serialization
|
|
(defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
|
|
(setf (gethash object ,stable) value))
|
|
(defmethod set-extension ((object ,type) (slot (eql ',fname)) value)
|
|
(setf (gethash object ,stable) value))
|
|
(defmethod has-extension ((object ,type) (slot (eql ',fname)))
|
|
(multiple-value-bind (value foundp)
|
|
(gethash object ,stable)
|
|
(declare (ignore value))
|
|
foundp))
|
|
(defmethod clear-extension ((object ,type) (slot (eql ',fname)))
|
|
(remhash object ,stable))
|
|
(defmethod (setf ,reader) (val (object ,type))
|
|
(,writer object val)))))))
|
|
(setf (proto-kind new-field) :extends)
|
|
(appendf (proto-fields extends) (list new-field))
|
|
(appendf (proto-extended-fields extends) (list new-field)))
|
|
(collect-form `(record-protobuf-object ',type ,extends :message))
|
|
`(progn ,@forms))))
|
|
|
|
(defun index-within-extensions-p (index message)
|
|
(let ((extensions (proto-extensions message)))
|
|
(some #'(lambda (ext)
|
|
(and (i>= index (proto-extension-from ext))
|
|
(i<= index (proto-extension-to ext))))
|
|
extensions)))
|
|
|
|
(defun process-field (field &key alias-for field-offset bool-index bool-values)
|
|
"Process one field descriptor within 'define-message' or 'define-extend'.
|
|
Returns a field-descriptor object, a defstruct slot form, the field number,
|
|
and a boolean indicating whether FIELD has an offset.
|
|
|
|
Parameters:
|
|
FIELD: A list whose first element is the Lisp symbol for the field name, followed
|
|
by keyword / value pairs:
|
|
:type - A symbol naming the Lisp type of this field.
|
|
:index - The field number.
|
|
:name - Optional. Used to override the defaultly generated protobuf field name.
|
|
:default - Optional. The default value for the slot.
|
|
:packed - Determines if the field is packed with respect to the proto API.
|
|
:lazy - Determines whether to lazily deserialize the field with respect to the proto API.
|
|
:label - One of (:repeated :vector), (:repeated :list), (:optional), (:required).
|
|
:kind - One of :enum :map :scalar :group :message :extends
|
|
ALIAS-FOR is to determine if this is an alias for a difference field.
|
|
FIELD-OFFSET is an internal concept of the index of a field
|
|
in a proto-message.
|
|
BOOL-INDEX: nil if this is not a simple (non-repeated) boolean field.
|
|
If this is a simple boolean field, this is the index into the bit vector of all
|
|
simple boolean fields (i.e., the bool-values argument).
|
|
BOOL-VALUES: A bit-vector holding all boolean values for a message.
|
|
On exit this vector holds the correct default value for FIELD if it is a
|
|
simple boolean field."
|
|
(destructuring-bind (slot &key type name (default nil default-p) packed lazy
|
|
json-name index label kind &allow-other-keys)
|
|
field
|
|
(assert (and json-name index))
|
|
(let* (;; Public accessors and setters for slots should be defined later.
|
|
(internal-slot-name (fintern "%~A" slot)))
|
|
(multiple-value-bind (label repeated-storage-type) (values-list label)
|
|
(let* (;; Proto3 optional fields do not have offsets, as they don't have has-* functions.
|
|
;; Note that proto2-style optional fields in proto3 files are wrapped in oneofs by
|
|
;; protoc, and hence process-field is never called.
|
|
(offset (and (not (eq (proto-syntax *current-file-descriptor*) :proto3))
|
|
(not (eq label :repeated))
|
|
field-offset))
|
|
(default
|
|
(if default-p
|
|
default
|
|
$empty-default))
|
|
(default (if default-p default $empty-default))
|
|
(cslot (unless alias-for
|
|
;; Enum type specifiers might not be loaded.
|
|
;; Seems like this could be fixed...
|
|
(let ((type (if (eq kind :enum) 'keyword type)))
|
|
(make-field-data
|
|
:internal-slot-name internal-slot-name
|
|
:external-slot-name slot
|
|
:type
|
|
(cond ((and (eq label :repeated) (eq repeated-storage-type :vector))
|
|
`(vector-of ,type))
|
|
((and (eq label :repeated) (eq repeated-storage-type :list))
|
|
`(list-of ,type))
|
|
((member kind '(:message :group))
|
|
`(or null ,type))
|
|
(t `,type))
|
|
:accessor slot
|
|
:initarg (kintern (symbol-name slot))
|
|
:container (when (eq label :repeated) repeated-storage-type)
|
|
:kind kind
|
|
:initform
|
|
(cond ((eq label :repeated)
|
|
;; Repeated fields get a container for their elements
|
|
(if (eq repeated-storage-type :vector)
|
|
`(make-array 5 :fill-pointer 0 :adjustable t)
|
|
nil))
|
|
((and (not default-p)
|
|
(eq label :optional)
|
|
;; Use unbound for booleans only
|
|
(not (eq type 'boolean)))
|
|
nil)
|
|
(default-p `,default))))))
|
|
(field (make-instance
|
|
'field-descriptor
|
|
:name (or name (slot-name->proto slot))
|
|
:type (if (eq kind :enum) (enum-open-type type) type)
|
|
:kind kind
|
|
:class type
|
|
:qualified-name (make-qualified-name *current-message-descriptor*
|
|
(or name (slot-name->proto slot)))
|
|
:label label
|
|
:index index
|
|
:field-offset offset
|
|
:internal-field-name internal-slot-name
|
|
:external-field-name slot
|
|
:json-name json-name
|
|
:default default
|
|
;; Pack the field only if requested and it actually makes sense
|
|
:packed (and (eq label :repeated) packed t)
|
|
:container (when (eq label :repeated) repeated-storage-type)
|
|
:lazy (and lazy t)
|
|
:bool-index bool-index)))
|
|
(when (and bool-index default (not (eq default $empty-default)))
|
|
(setf (bit bool-values bool-index) 1))
|
|
(values field cslot index (and offset t)))))))
|
|
|
|
(defparameter *rpc-call-function* nil
|
|
"The function that implements RPC client-side calls. This function must have a signature
|
|
matching (channel method request response &key callback). Set this when an RPC package that uses
|
|
cl-protobufs is loaded.")
|
|
|
|
(defparameter *rpc-streaming-client-function* nil
|
|
"This function should implement the dispatch calls for client side streaming calls. This function
|
|
must have a signature matching (type &key channel method request call) and have methods for types
|
|
in :start :send :receive :close :cleanup. Set this when an RPC package that uses cl-protobufs is
|
|
loaded.")
|
|
|
|
(defmacro assert-rpc-function-defined (symbol)
|
|
"Assert that SYMBOL is not NIL, otherwise signal an error."
|
|
`(assert ,symbol () (format nil "~a is not bound to an RPC function." ',symbol)))
|
|
|
|
(defmacro define-service (type (&key name options source-location) &body method-specs)
|
|
"Define a service named TYPE and a generic function for each method.
|
|
NAME can be used to override the defaultly generated service name.
|
|
OPTIONS is a set of keyword/value pairs, both of which are strings.
|
|
SOURCE-LOCATION is an optional source location.
|
|
|
|
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-option (if (symbolp key) (slot-name->proto key) key) val)))
|
|
(service (make-instance 'service-descriptor
|
|
:class type
|
|
:name name
|
|
:qualified-name (make-qualified-name *current-file-descriptor*
|
|
name)
|
|
:options options
|
|
:source-location source-location))
|
|
(index 0))
|
|
(with-collectors ((forms collect-form))
|
|
(dolist (method method-specs)
|
|
(destructuring-bind (function (&rest types) &key name options)
|
|
method
|
|
(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-streaming (and (listp input-type)
|
|
(getf (cdr input-type) :stream)))
|
|
(input-type (if (listp input-type) (car input-type) input-type))
|
|
(qual-input-type (make-qualified-name *current-file-descriptor*
|
|
(class-name->proto input-type)))
|
|
(output-name (and (listp output-type)
|
|
(getf (cdr output-type) :name)))
|
|
(output-streaming (and (listp output-type)
|
|
(getf (cdr output-type) :stream)))
|
|
(output-type (if (listp output-type) (car output-type) output-type))
|
|
(qual-output-type (make-qualified-name *current-file-descriptor*
|
|
(class-name->proto 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-option
|
|
(if (symbolp key)
|
|
(slot-name->proto key)
|
|
key)
|
|
val)))
|
|
(package (let ((name (strcat (package-name *package*) "-RPC")))
|
|
(or (find-package name)
|
|
(make-package name :use '()))))
|
|
(client-fn (intern (nstring-upcase (format nil "CALL-~A" function)) package))
|
|
(old-server-fn (intern (nstring-upcase (format nil "~A-IMPL" function)) package))
|
|
(server-fn (intern (nstring-upcase (format nil "~A" function)) package))
|
|
(method (make-instance
|
|
'method-descriptor
|
|
:class function
|
|
:name (or name (class-name->proto function))
|
|
:qualified-name (make-qualified-name *current-file-descriptor*
|
|
(or name
|
|
(class-name->proto function)))
|
|
:service-name (proto-name service)
|
|
:client-stub client-fn
|
|
:server-stub server-fn
|
|
;; TODO(jgodbout): Remove this.
|
|
:old-server-stub old-server-fn
|
|
:input-type input-type
|
|
:input-name (or input-name qual-input-type)
|
|
:input-streaming input-streaming
|
|
:output-type output-type
|
|
:output-name (or output-name qual-output-type)
|
|
:output-streaming output-streaming
|
|
:streams-type streams-type
|
|
:streams-name (and streams-type
|
|
(or streams-name (class-name->proto streams-type)))
|
|
:index (iincf index)
|
|
:options options)))
|
|
(appendf (proto-methods service) (list method))
|
|
;; The following are the hooks to an RPC implementation
|
|
(let* ((vrequest (intern "REQUEST" package))
|
|
(vresponse (intern "RESPONSE" package))
|
|
(vchannel (intern "CHANNEL" package))
|
|
(vcallback (intern "CALLBACK" package))
|
|
(vrpc (intern "RPC" package))
|
|
(call (gensym "CALL")))
|
|
;; The client side stub, e.g., 'read-air-reservation'.
|
|
;; The expectation is that the RPC implementation will provide code to make it
|
|
;; easy to implement a method for this on each kind of channel (HTTP, TCP socket,
|
|
;; IPC, etc). Unlike C++/Java/Python, we don't need a client-side subclass,
|
|
;; because we can just use multi-methods.
|
|
;; The 'do-XXX' method calls the RPC code with the channel, the method
|
|
;; (i.e., a 'method-descriptor' object), the request and the callback function.
|
|
;; The RPC code should take care of serializing the input, transmitting the
|
|
;; request over the wire, waiting for input (or not, if it's asynchronous),
|
|
;; filling in the output, and either returning the response (if synchronous)
|
|
;; or calling the callback with the response as an argument (if asynchronous).
|
|
;; It will also deserialize the response so that the client code sees the
|
|
;; response as an application object.
|
|
(collect-form
|
|
`(defgeneric ,client-fn (,vchannel ,vrequest &key ,vcallback ,vresponse)
|
|
#+(or ccl)
|
|
(declare (values ,output-type))
|
|
(:method (,vchannel ,vrequest &key ,vcallback ,vresponse)
|
|
(declare (ignorable ,vchannel ,vcallback))
|
|
(assert-rpc-function-defined *rpc-call-function*)
|
|
(funcall *rpc-call-function* ,vchannel ',method ,vrequest ,vresponse
|
|
:callback ,vcallback
|
|
; :type ',input-type
|
|
))))
|
|
(when (or input-streaming output-streaming)
|
|
(let ((start-call
|
|
(intern (string-upcase (format nil "~A/START" function))
|
|
package))
|
|
(send-call
|
|
(intern (nstring-upcase (format nil "~A/SEND" function))
|
|
package))
|
|
(receive-call
|
|
(intern (nstring-upcase (format nil "~A/RECEIVE" function))
|
|
package))
|
|
(close-call
|
|
(intern (nstring-upcase (format nil "~A/CLOSE" function))
|
|
package))
|
|
(cleanup-call
|
|
(intern (nstring-upcase (format nil "~A/CLEANUP" function))
|
|
package)))
|
|
(collect-form
|
|
`(defun ,start-call (,vchannel)
|
|
(assert-rpc-function-defined *rpc-streaming-client-function*)
|
|
(funcall *rpc-streaming-client-function*
|
|
:start :channel ,vchannel :method ',method)))
|
|
(collect-form
|
|
`(defun ,send-call (,call ,vrequest)
|
|
(assert-rpc-function-defined *rpc-streaming-client-function*)
|
|
(funcall *rpc-streaming-client-function*
|
|
:send :call ,call :request ,vrequest)))
|
|
(collect-form
|
|
`(defun ,receive-call (,call)
|
|
(assert-rpc-function-defined *rpc-streaming-client-function*)
|
|
(funcall *rpc-streaming-client-function* :receive :call ,call)))
|
|
(collect-form
|
|
`(defun ,close-call (,call)
|
|
(assert-rpc-function-defined *rpc-streaming-client-function*)
|
|
(funcall *rpc-streaming-client-function* :close :call ,call)))
|
|
(collect-form
|
|
`(defun ,cleanup-call (,call)
|
|
(assert-rpc-function-defined *rpc-streaming-client-function*)
|
|
(funcall *rpc-streaming-client-function* :cleanup :call ,call)))
|
|
(collect-form
|
|
`(export '(,start-call
|
|
,send-call
|
|
,receive-call
|
|
,close-call
|
|
,cleanup-call)
|
|
,package))))
|
|
|
|
;; The server side stub, e.g., 'do-read-air-reservation'.
|
|
;; The expectation is that the server-side program will implement
|
|
;; a method with the business logic for this on each kind of channel
|
|
;; (HTTP, TCP socket, IPC, etc), possibly on a server-side subclass
|
|
;; of the input class.
|
|
;; The business logic is expected to perform the correct operations on
|
|
;; the input object, which arrived via Protobufs, and produce an output
|
|
;; of the given type, which will be serialized and sent back over the wire.
|
|
;; The channel objects hold client identity information, deadline info,
|
|
;; etc, and can be side-effected to indicate success or failure.
|
|
;; The RPC code provides the channel classes and does (de)serialization, etc.
|
|
;; The VRPC argument is always of type RPC2:SERVER-RPC.
|
|
(collect-form `(defgeneric ,old-server-fn (,vchannel ,vrequest ,vrpc)
|
|
#+(or ccl)
|
|
(declare (values ,output-type))))
|
|
(collect-form `(defgeneric ,server-fn (,vrequest ,call)
|
|
#+(or ccl)
|
|
(declare (values ,output-type))))))))
|
|
(collect-form `(record-protobuf-object ',type ,service :service))
|
|
`(progn ,@forms))))
|