define-proto.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 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 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 or :proto3
                      ;; in case syntax is NIL.
                      :syntax   (or syntax :proto2 :proto3)
                      :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 &optional default)
  (: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.
DEFAULT is the value to use if INTEGER is not contained in the enum."))

(defgeneric enum-keyword-to-int (enum-type keyword &optional default)
  (:documentation
   "Converts a KEYWORD to its corresponding integer value.  ENUM-TYPE is the
enum-type name.  DEFAULT is the value to use if KEYWORD is a not contained in
the enum."))

(defun make-enum-conversion-forms (type value-descriptors)
  "Generates forms for enum <-> integer conversion functions. TYPE is the enum
type name.  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 &optional default)
         (declare (type keyword enum))
         (let ((int (case enum
                      ,@(loop for desc in value-descriptors
                              collect `(,(enum-value-descriptor-name desc)
                                        ,(enum-value-descriptor-value desc))))))
           (or int default)))

       (defun ,int2key (numeral &optional default)
         (declare (type int32 numeral))
         (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))))))
           (or key default)))

       (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 &optional default)
         (,key2int keyword default))
       (defmethod cl-protobufs:enum-int-to-keyword
           ((e (eql ',type)) numeral &optional default)
         (,int2key numeral default)))))

(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)))))

(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))))
    (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-name (kintern (symbol-name name)))
               (val-desc (make-enum-value-descriptor :value value :name val-name)))
          (collect-name val-name)
          (collect-value-descriptor val-desc)))
      (let ((enum (make-enum-descriptor :class type
                                        :name name
                                        :values value-descriptors)))
        (collect-form `(deftype ,type () '(member ,@names)))
        (collect-form (make-enum-conversion-forms 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))
        ;; 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 :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))
        (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 ,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)))))))))

        ;; 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)

        ;; has-* functions are not exported for proto3-style optional fields. They are only for
        ;; internal usage.
        ,(unless (eq (proto-syntax *current-file-descriptor*) :proto3)
           `(export '(,has-function-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))
         (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 ,has-function-name (,obj)
          (not (eql (oneof-set-field (,hidden-accessor-name ,obj)) nil)))

        (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 ,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))
                   (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 ,has-function-name (,obj)
                    (eq (oneof-set-field (,hidden-accessor-name ,obj))
                        ,oneof-offset))

                  (defun-inline ,clear-function-name (,obj)
                    (when (,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 '(,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) 'keyword 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
          ;; For enum accessors we return either the enum keyword or :%undefined-<n>
          (let ((structure-field-type (if (eq (proto-kind field) :enum)
                                          'keyword field-type)))
            (cond ((eq (proto-container field) :vector)
                   `(cl-protobufs:vector-of ,structure-field-type))
                  ((eq (proto-container field) :list)
                   `(cl-protobufs:list-of ,structure-field-type))
                  ((member (proto-kind field) '(:message :group :extends))
                   `(or null ,structure-field-type))
                  (t structure-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))
         (is-set-init (field-data-initform
                       (find-if #'(lambda (el)
                                    (eq (field-data-internal-slot-name el) '%%is-set))
                                slots)))
         (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)
           (setf (,is-set-name ,obj) ,is-set-init))

         (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
                        ;; For enums we have to keep track of unknown
                        ;; deserialized values so it can't be a strict
                        ;; member of a set of keywords...
                        (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) 'keyword 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))
                 (server-fn (intern (nstring-upcase (format nil "~A-IMPL" 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
                           :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)))
              ;; 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))
                      (call  (gensym "CALL")))
                  (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 ,server-fn (,vchannel ,vrequest ,vrpc)
                               #+(or ccl)
                               (declare (values ,output-type))))))))
      (collect-form `(appendf (proto-services *current-file-descriptor*) (list ,service)))
      `(progn ,@forms))))