model-classes.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protol buffers model classes
  15
  16 (defvar *all-schemas* (make-hash-table :test #'equal)
  17   "A table mapping names to 'protobuf-schema' objects.")
  18
  19 (defgeneric find-schema (name)
  20   (:documentation
  21    "Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
  22
  23 (defmethod find-schema ((name symbol))
  24   (values (gethash (keywordify name) *all-schemas*)))
  25
  26 (defmethod find-schema ((name string))
  27   (values (gethash (string-upcase name) *all-schemas*)))
  28
  29 (defmethod find-schema ((path pathname))
  30   "Given a pathname, return the 'protobuf-schema' object that came from that path."
  31   (values (gethash (make-pathname :type nil :defaults (truename path)) *all-schemas*)))
  32
  33
  34 (defvar *all-messages* (make-hash-table :test #'equal)
  35   "A table mapping Lisp class names to 'protobuf-message' objects.")
  36
  37 (defgeneric find-message-for-class (class)
  38   (:documentation
  39    "Given a class or class name, return the message that globally has that name."))
  40
  41 (defmethod find-message-for-class (class)
  42   "Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
  43   (values (gethash class *all-messages*)))
  44
  45 (defmethod find-message-for-class ((class class))
  46   (values (gethash (class-name class) *all-messages*)))
  47
  48
  49 ;; A few things (the pretty printer) want to keep track of the current schema
  50 (defvar *protobuf* nil
  51   "The Protobufs object currently being defined, e.g., a schema, a message, etc.")
  52
  53 (defvar *protobuf-package* nil
  54   "The Lisp package in which the Protobufs schema is being defined.")
  55
  56 (defvar *protobuf-conc-name* nil
  57   "A global conc-name to use for all the messages in this schema. This controls
  58    the name of the accessors the fields of each message.
  59    When it's nil, there is no global conc-name.
  60    When it's t, each message will use the message name as the conc-name.
  61    When it's a string, that string will be used as the conc-name for each message.
  62    'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
  63    every message has an accessor whose name is the name of the field.")
  64
  65 (defvar *protobuf-search-path* ()
  66   "A search-path to use to resolve any relative pathnames.")
  67
  68 (defvar *protobuf-output-path* ()
  69   "A path to use to direct output during imports, etc.")
  70
  71
  72 ;;; The model classes
  73
  74 (defclass abstract-protobuf () ())
  75
  76 (defclass base-protobuf (abstract-protobuf)
  77   ((class :type (or null symbol)                ;the Lisp name for this object
  78           :accessor proto-class                 ;this often names a type or class
  79           :initarg :class
  80           :initform nil)
  81    (name :type (or null string)                 ;the Protobufs name for this enum, message, etc
  82          :reader proto-name
  83          :initarg :name
  84          :initform nil)
  85    (full-name :type (or null string)            ;the fully qualified name, e.g., "proto2.MessageSet"
  86               :accessor proto-qualified-name
  87               :initarg :qualified-name
  88               :initform nil)
  89    (options :type (list-of protobuf-option)     ;options, mostly just passed along
  90             :accessor proto-options
  91             :initarg :options
  92             :initform ())
  93    (doc :type (or null string)                  ;documentation for this object
  94         :accessor proto-documentation
  95         :initarg :documentation
  96         :initform nil))
  97   (:documentation
  98    "The base class for all Protobufs model classes."))
  99
 100 (defun find-qualified-name (name protos
 101                             &key (proto-key #'proto-name) (lisp-key #'proto-class))
 102   "Find something by its string name.
 103    First do a simple name match.
 104    Failing that, exhaustively search qualified names."
 105   (or (find name protos :key proto-key :test #'string=)
 106       ;; Get desperate in the face of incomplete namespace support
 107       ;;--- This needs to be more sophisticated than just using Lisp packages
 108       (multiple-value-bind (name package path other)
 109           (proto->class-name name)
 110         (declare (ignore path))
 111         (let* ((name   (string name))
 112                (symbol (or (and package (find-symbol name package))
 113                            (and other
 114                                 (find-proto-package other)
 115                                 (find-symbol name (find-proto-package other))))))
 116           (when symbol
 117             (find symbol protos :key lisp-key))))))
 118
 119
 120 ;; A Protobufs schema, corresponds to one .proto file
 121 (defclass protobuf-schema (base-protobuf)
 122   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
 123            :accessor proto-syntax
 124            :initarg :syntax
 125            :initform "proto2")
 126    (package :type (or null string)              ;the Protobufs package
 127             :accessor proto-package
 128             :initarg :package
 129             :initform nil)
 130    (lisp-pkg :type (or null string)              ;the Lisp package, from 'option lisp_package = ...'
 131              :accessor proto-lisp-package
 132              :initarg :lisp-package
 133              :initform nil)
 134    (imports :type (list-of string)              ;the names of schemas to be imported
 135             :accessor proto-imports
 136             :initarg :imports
 137             :initform ())
 138    (schemas :type (list-of protobuf-schema)     ;the schemas that were successfully imported
 139             :accessor proto-imported-schemas    ;this gets used for chasing namespaces
 140             :initform ())
 141    (enums :type (list-of protobuf-enum)         ;the set of enum types
 142           :accessor proto-enums
 143           :initarg :enums
 144           :initform ())
 145    (messages :type (list-of protobuf-message)   ;all the messages within this protobuf
 146              :accessor proto-messages
 147              :initarg :messages
 148              :initform ())
 149    (extenders :type (list-of protobuf-message)  ;the 'extend' messages in this protobuf
 150               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 151               :initarg :extenders
 152               :initform ())
 153    (services :type (list-of protobuf-service)
 154              :accessor proto-services
 155              :initarg :services
 156              :initform ()))
 157   (:documentation
 158    "The model class that represents a Protobufs schema, i.e., one .proto file."))
 159
 160 (defmethod make-load-form ((s protobuf-schema) &optional environment)
 161   (with-slots (class name) s
 162     (multiple-value-bind (constructor initializer)
 163         (make-load-form-saving-slots s :environment environment)
 164       (values `(let ((s ,constructor))
 165                   (record-protobuf s ',class ',name nil)
 166                   s)
 167               initializer))))
 168
 169 (defgeneric record-protobuf (schema &optional symbol name type)
 170   (:documentation
 171    "Record all the names by which the Protobufs schema might be known.")
 172   (:method ((schema protobuf-schema) &optional symbol name type)
 173     (declare (ignore type))
 174     (let ((symbol (or symbol (proto-class schema)))
 175           (name   (or name (proto-name schema))))
 176       (when symbol
 177         (setf (gethash (keywordify symbol) *all-schemas*) schema))
 178       (when name
 179         (setf (gethash (string-upcase name) *all-schemas*) schema))
 180       (let ((path (or *compile-file-pathname* *load-pathname*)))
 181         (when path
 182           ;; Record the file from which the Protobufs schema came, sans file type
 183           (setf (gethash (make-pathname :type nil :defaults (truename path)) *all-schemas*) schema))))))
 184
 185 (defmethod print-object ((s protobuf-schema) stream)
 186   (print-unreadable-object (s stream :type t :identity t)
 187     (format stream "~@[~S~]~@[ (package ~A)~]"
 188             (proto-class s) (proto-package s))))
 189
 190 (defgeneric find-enum (protobuf type)
 191   (:documentation
 192    "Given a Protobufs schema or message and the name of an enum type,
 193     returns the Protobufs enum corresponding to the type."))
 194
 195 (defmethod find-enum ((schema protobuf-schema) (type symbol))
 196   (labels ((find-it (schema)
 197              (let ((enum (find type (proto-enums schema) :key #'proto-class)))
 198                (when enum
 199                  (return-from find-enum enum))
 200                (map () #'find-it (proto-imported-schemas schema)))))
 201     (find-it schema)))
 202
 203 (defmethod find-enum ((schema protobuf-schema) (name string))
 204   (labels ((find-it (schema)
 205              (let ((enum (find-qualified-name name (proto-enums schema))))
 206                (when enum
 207                  (return-from find-enum enum))
 208                (map () #'find-it (proto-imported-schemas schema)))))
 209     (find-it schema)))
 210
 211 (defgeneric find-message (protobuf type)
 212   (:documentation
 213    "Given a Protobufs schema or message and a type name or class name,
 214     returns the Protobufs message corresponding to the type."))
 215
 216 (defmethod find-message ((schema protobuf-schema) (type symbol))
 217   ;; Extended messages "shadow" non-extended ones
 218   (labels ((find-it (schema)
 219              (let ((message (or (find type (proto-extenders schema) :key #'proto-class)
 220                                 (find type (proto-messages  schema) :key #'proto-class))))
 221                (when message
 222                  (return-from find-message message))
 223                (map () #'find-it (proto-imported-schemas schema)))))
 224     (find-it schema)))
 225
 226 (defmethod find-message ((schema protobuf-schema) (type class))
 227   (find-message schema (class-name type)))
 228
 229 (defmethod find-message ((schema protobuf-schema) (name string))
 230   (labels ((find-it (schema)
 231              (let ((message (or (find-qualified-name name (proto-extenders schema))
 232                                 (find-qualified-name name (proto-messages  schema)))))
 233                (when message
 234                  (return-from find-message message))
 235                (map () #'find-it (proto-imported-schemas schema)))))
 236     (find-it schema)))
 237
 238 (defgeneric find-service (protobuf name)
 239   (:documentation
 240    "Given a Protobufs schema,returns the Protobufs service of the given name."))
 241
 242 (defmethod find-service ((schema protobuf-schema) (name symbol))
 243   (find name (proto-services schema) :key #'proto-class))
 244
 245 (defmethod find-service ((schema protobuf-schema) (name string))
 246   (find-qualified-name name (proto-services schema)))
 247
 248 ;; Convenience function that accepts a schema name
 249 (defmethod find-service (schema-name name)
 250   (let ((schema (find-schema schema-name)))
 251     (assert schema ()
 252             "There is no schema named ~A" schema-name)
 253     (find-service schema name)))
 254
 255
 256 ;; We accept and store any option, but only act on a few: default, packed,
 257 ;; optimize_for, lisp_package, lisp_name, lisp_alias
 258 (defclass protobuf-option (abstract-protobuf)
 259   ((name :type string                           ;the key
 260          :reader proto-name
 261          :initarg :name)
 262    (value :accessor proto-value                 ;the (untyped) value
 263           :initarg :value
 264           :initform nil)
 265    (type :type (or null symbol)                 ;(optional) Lisp type,
 266          :reader proto-type                     ;  one of string, integer, sybol (for now)
 267          :initarg :type
 268          :initform 'string))
 269   (:documentation
 270    "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
 271
 272 (defmethod make-load-form ((o protobuf-option) &optional environment)
 273   (make-load-form-saving-slots o :environment environment))
 274
 275 (defmethod print-object ((o protobuf-option) stream)
 276   (print-unreadable-object (o stream :type t :identity t)
 277     (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
 278
 279 (defgeneric find-option (protobuf name)
 280   (:documentation
 281    "Given a Protobufs schema, message, enum, etc and the name of an option,
 282     returns the value of the option and its (Lisp) type. The third value is
 283     true if an option was found, otherwise it is false."))
 284
 285 (defmethod find-option ((protobuf base-protobuf) (name string))
 286   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 287     (if option
 288       (values (proto-value option) (proto-type option) t)
 289       (values nil nil nil))))
 290
 291 (defmethod find-option ((options list) (name string))
 292   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 293     (if option
 294       (values (proto-value option) (proto-type option) t)
 295       (values nil nil nil))))
 296
 297 (defgeneric remove-options (protobuf &rest names)
 298   (:documentation
 299    "Given a Protobufs schema, message, enum, etc and a set of option names,
 300     remove all of those options from the set of options."))
 301
 302 (defmethod remove-options ((protobuf base-protobuf) &rest names)
 303   (dolist (name names (proto-options protobuf))
 304     (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 305       (when option
 306         ;; This side-effects 'proto-options'
 307         (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
 308
 309 (defmethod remove-options ((options list) &rest names)
 310   (dolist (name names options)
 311     (let ((option (find name options :key #'proto-name :test #'option-name=)))
 312       (when option
 313         ;; This does not side-effect the list of options
 314         (setq options (remove option options))))))
 315
 316 (defun option-name= (name1 name2)
 317   (let* ((name1  (string name1))
 318          (name2  (string name2))
 319          (start1 (if (eql (char name1 0) #\() 1 0))
 320          (start2 (if (eql (char name2 0) #\() 1 0))
 321          (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 322          (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 323     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 324
 325
 326 ;; A Protobufs enumeration
 327 (defclass protobuf-enum (base-protobuf)
 328   ((alias :type (or null symbol)                ;use this if you want to make this enum
 329           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 330           :initarg :alias-for
 331           :initform nil)
 332    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 333            :accessor proto-values
 334            :initarg :values
 335            :initform ()))
 336   (:documentation
 337    "The model class that represents a Protobufs enumeration type."))
 338
 339 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 340   (make-load-form-saving-slots e :environment environment))
 341
 342 (defmethod print-object ((e protobuf-enum) stream)
 343   (print-unreadable-object (e stream :type t :identity t)
 344     (format stream "~S~@[ (alias for ~S)~]"
 345             (proto-class e) (proto-alias-for e))))
 346
 347
 348 ;; A Protobufs value within an enumeration
 349 (defclass protobuf-enum-value (base-protobuf)
 350   ((index :type (signed-byte 32)                ;the numeric value of the enum
 351           :accessor proto-index
 352           :initarg :index)
 353    (value :type (or null symbol)                ;the Lisp value of the enum
 354           :accessor proto-value
 355           :initarg :value
 356           :initform nil))
 357   (:documentation
 358    "The model class that represents a Protobufs enumeration value."))
 359
 360 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 361   (make-load-form-saving-slots v :environment environment))
 362
 363 (defmethod print-object ((v protobuf-enum-value) stream)
 364   (print-unreadable-object (v stream :type t :identity t)
 365     (format stream "~A = ~D"
 366             (proto-name v) (proto-index v))))
 367
 368
 369 ;; A Protobufs message
 370 (defclass protobuf-message (base-protobuf)
 371   ((parent :type (or protobuf-schema protobuf-message)
 372            :accessor proto-parent
 373            :initarg :parent)
 374    (conc :type (or null string)                 ;the conc-name used for Lisp accessors
 375          :accessor proto-conc-name
 376          :initarg :conc-name
 377          :initform nil)
 378    (alias :type (or null symbol)                ;use this if you want to make this message
 379           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 380           :initarg :alias-for
 381           :initform nil)
 382    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 383           :accessor proto-enums
 384           :initarg :enums
 385           :initform ())
 386    (messages :type (list-of protobuf-message)   ;all the messages embedded in this one
 387              :accessor proto-messages
 388              :initarg :messages
 389              :initform ())
 390    (extenders :type (list-of protobuf-message)  ;the 'extend' messages embedded in this one
 391               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 392               :initarg :extenders
 393               :initform ())
 394    (fields :type (list-of protobuf-field)       ;all the fields of this message
 395            :accessor proto-fields               ;this includes local ones and extended ones
 396            :initarg :fields
 397            :initform ())
 398    (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
 399                     :accessor proto-extended-fields
 400                     :initform ())
 401    (extensions :type (list-of protobuf-extension) ;any extension ranges
 402                :accessor proto-extensions
 403                :initarg :extensions
 404                :initform ())
 405    ;; :message is an ordinary message
 406    ;; :group is a (deprecated) group (kind of an "implicit" message)
 407    ;; :extends is an 'extends' to an existing message
 408    (message-type :type (member :message :group :extends)
 409                  :accessor proto-message-type
 410                  :initarg :message-type
 411                  :initform :message))
 412     (:documentation
 413    "The model class that represents a Protobufs message."))
 414
 415 (defmethod make-load-form ((m protobuf-message) &optional environment)
 416   (with-slots (class name message-type) m
 417     (multiple-value-bind (constructor initializer)
 418         (make-load-form-saving-slots m :environment environment)
 419       (values (if (eq message-type :extends)
 420                 constructor
 421                 `(let ((m ,constructor))
 422                    (record-protobuf m ',class ',name ',message-type)
 423                    m))
 424               initializer))))
 425
 426 (defmethod record-protobuf ((message protobuf-message) &optional class name type)
 427   ;; No need to record an extension, it's already been recorded
 428   (let ((class (or class (proto-class message)))
 429         (name  (or name (proto-name message)))
 430         (type  (or type (proto-message-type message))))
 431     (unless (eq type :extends)
 432       (when class
 433         (setf (gethash class *all-messages*) message))
 434       (when name
 435         (setf (gethash name *all-messages*) message)))))
 436
 437 (defmethod print-object ((m protobuf-message) stream)
 438   (print-unreadable-object (m stream :type t :identity t)
 439     (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 440             (proto-class m) (proto-alias-for m)
 441             (eq (proto-message-type m) :group)
 442             (eq (proto-message-type m) :extends))))
 443
 444 (defmethod find-message ((message protobuf-message) (type symbol))
 445   ;; Extended messages "shadow" non-extended ones
 446   (or (find type (proto-extenders message) :key #'proto-class)
 447       (find type (proto-messages message) :key #'proto-class)
 448       (find-message (proto-parent message) type)))
 449
 450 (defmethod find-message ((message protobuf-message) (type class))
 451   (find-message message (class-name type)))
 452
 453 (defmethod find-message ((message protobuf-message) (name string))
 454   (or (find-qualified-name name (proto-extenders message))
 455       (find-qualified-name name (proto-messages message))
 456       (find-message (proto-parent message) name)))
 457
 458 (defmethod find-enum ((message protobuf-message) type)
 459   (or (find type (proto-enums message) :key #'proto-class)
 460       (find-enum (proto-parent message) type)))
 461
 462 (defmethod find-enum ((message protobuf-message) (name string))
 463   (or (find-qualified-name name (proto-enums message))
 464       (find-enum (proto-parent message) name)))
 465
 466 (defgeneric find-field (message name)
 467   (:documentation
 468    "Given a Protobufs message and a slot name, field name or index,
 469     returns the Protobufs field having that name."))
 470
 471 (defmethod find-field ((message protobuf-message) (name symbol))
 472   (find name (proto-fields message) :key #'proto-value))
 473
 474 (defmethod find-field ((message protobuf-message) (name string))
 475   (find-qualified-name name (proto-fields message) :lisp-key #'proto-value))
 476
 477 (defmethod find-field ((message protobuf-message) (index integer))
 478   (find index (proto-fields message) :key #'proto-index))
 479
 480
 481 ;; Extensions protocol
 482 (defgeneric get-extension (object slot)
 483   (:documentation
 484    "Returns the value of the extended slot 'slot' in 'object'"))
 485
 486 (defgeneric set-extension (object slot value)
 487   (:documentation
 488    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 489
 490 (defgeneric has-extension (object slot)
 491   (:documentation
 492    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 493   ;; The only default method is for 'has-extension'
 494   ;; It's an error to call the other three functions on a non-extendable object
 495   (:method ((object standard-object) slot)
 496     (declare (ignore slot))
 497     nil))
 498
 499 (defgeneric clear-extension (object slot)
 500   (:documentation
 501    "Clears the value of the extended slot 'slot' from 'object'"))
 502
 503
 504 (defconstant $empty-default 'empty-default
 505   "The marker used in 'proto-default' used to indicate that there is no default value.")
 506 (defconstant $empty-list    'empty-list)
 507 (defconstant $empty-vector  'empty-vector)
 508
 509 ;; A Protobufs field within a message
 510 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 511 (defclass protobuf-field (base-protobuf)
 512   ((type :type string                           ;the name of the Protobuf type for the field
 513          :accessor proto-type
 514          :initarg :type)
 515    (required :type (member :required :optional :repeated)
 516              :accessor proto-required
 517              :initarg :required)
 518    (index :type (unsigned-byte 29)              ;the index number for this field
 519           :accessor proto-index                 ; which must be strictly positive
 520           :initarg :index)
 521    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 522           :accessor proto-value                 ;this also serves as the Lisp field name
 523           :initarg :value
 524           :initform nil)
 525    (reader :type (or null symbol)               ;a reader that is used to access the value
 526            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 527            :initarg :reader
 528            :initform nil)
 529    (writer :type (or null symbol list)          ;a writer that is used to set the value
 530            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 531            :initarg :writer
 532            :initform nil)
 533    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 534             :initarg :default
 535             :initform $empty-default)
 536    (packed :type (member t nil)                 ;packed, pulled out of the options
 537            :accessor proto-packed
 538            :initarg :packed
 539            :initform nil)
 540    ;; Copied from 'proto-message-type' of the field
 541    (message-type :type (member :message :group :extends)
 542                  :accessor proto-message-type
 543                  :initarg :message-type
 544                  :initform :message))
 545   (:documentation
 546    "The model class that represents one field within a Protobufs message."))
 547
 548 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 549   (declare (ignore initargs))
 550   (when (slot-boundp field 'index)
 551     (assert (and (plusp (proto-index field))
 552                  (not (<= 19000 (proto-index field) 19999))) ()
 553             "Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
 554
 555 (defmethod make-load-form ((f protobuf-field) &optional environment)
 556   (make-load-form-saving-slots f :environment environment))
 557
 558 (defmethod print-object ((f protobuf-field) stream)
 559   (print-unreadable-object (f stream :type t :identity t)
 560     (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 561             (proto-value f) (proto-class f) (proto-index f)
 562             (eq (proto-message-type f) :group)
 563             (eq (proto-message-type f) :extends))))
 564
 565 ;; The 'value' slot really holds the name of the slot,
 566 ;; so let's give it a better name
 567 (defmethod proto-slot ((field protobuf-field))
 568   (proto-value field))
 569
 570 (defmethod (setf proto-slot) (slot (field protobuf-field))
 571   (setf (proto-value field) slot))
 572
 573 (defgeneric empty-default-p (field)
 574   (:documentation
 575    "Returns true iff the default for the field is empty, ie, was not supplied.")
 576   (:method ((field protobuf-field))
 577     (let ((default (proto-default field)))
 578       (or (eq default $empty-default)
 579           (eq default $empty-list)
 580           (eq default $empty-vector)
 581           ;; Special handling for imported CLOS classes
 582           (and (not (eq (proto-required field) :optional))
 583                (or (null default) (equal default #())))))))
 584
 585 (defgeneric vector-field-p (field)
 586   (:documentation
 587    "Returns true if the storage for a 'repeated' field is a vector,
 588     returns false if the storage is a list.")
 589   (:method ((field protobuf-field))
 590     (let ((default (proto-default field)))
 591       (or (eq default $empty-vector)
 592           (and (vectorp default) (not (stringp default)))))))
 593
 594
 595 ;; An extension range within a message
 596 (defclass protobuf-extension (abstract-protobuf)
 597   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 598          :accessor proto-extension-from
 599          :initarg :from)
 600    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 601        :accessor proto-extension-to
 602        :initarg :to))
 603   (:documentation
 604    "The model class that represents an extension range within a Protobufs message."))
 605
 606 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 607   (make-load-form-saving-slots e :environment environment))
 608
 609 (defmethod print-object ((e protobuf-extension) stream)
 610   (print-unreadable-object (e stream :type t :identity t)
 611     (format stream "~D - ~D"
 612             (proto-extension-from e) (proto-extension-from e))))
 613
 614
 615 ;; A Protobufs service
 616 (defclass protobuf-service (base-protobuf)
 617   ((methods :type (list-of protobuf-method)     ;the methods in the service
 618             :accessor proto-methods
 619             :initarg :methods
 620             :initform ()))
 621   (:documentation
 622    "The model class that represents a Protobufs service."))
 623
 624 (defmethod make-load-form ((s protobuf-service) &optional environment)
 625   (make-load-form-saving-slots s :environment environment))
 626
 627 (defmethod print-object ((s protobuf-service) stream)
 628   (print-unreadable-object (s stream :type t :identity t)
 629     (format stream "~A"
 630             (proto-name s))))
 631
 632 (defgeneric find-method (service name)
 633   (:documentation
 634    "Given a Protobufs service and a method name,
 635     returns the Protobufs method having that name."))
 636
 637 (defmethod find-method ((service protobuf-service) (name symbol))
 638   (find name (proto-methods service) :key #'proto-class))
 639
 640 (defmethod find-method ((service protobuf-service) (name string))
 641   (find-qualified-name name (proto-methods service)))
 642
 643 (defmethod find-method ((service protobuf-service) (index integer))
 644   (find index (proto-methods service) :key #'proto-index))
 645
 646
 647 ;; A Protobufs method within a service
 648 (defclass protobuf-method (base-protobuf)
 649   ((client-fn :type symbol                      ;the Lisp name of the client stb
 650               :accessor proto-client-stub
 651               :initarg :client-stub)
 652    (server-fn :type symbol                      ;the Lisp name of the server stb
 653               :accessor proto-server-stub
 654               :initarg :server-stub)
 655    (itype :type symbol                          ;the Lisp type name of the input
 656           :accessor proto-input-type
 657           :initarg :input-type)
 658    (iname :type (or null string)                ;the Protobufs name of the input
 659           :accessor proto-input-name
 660           :initarg :input-name
 661           :initform nil)
 662    (otype :type symbol                          ;the Lisp type name of the output
 663           :accessor proto-output-type
 664           :initarg :output-type)
 665    (oname :type (or null string)                ;the Protobufs name of the output
 666           :accessor proto-output-name
 667           :initarg :output-name
 668           :initform nil)
 669    (index :type (unsigned-byte 32)              ;an identifying index for this method
 670           :accessor proto-index                 ; (used by Stubby)
 671           :initarg :index))
 672   (:documentation
 673    "The model class that represents one method with a Protobufs service."))
 674
 675 (defmethod make-load-form ((m protobuf-method) &optional environment)
 676   (make-load-form-saving-slots m :environment environment))
 677
 678 (defmethod print-object ((m protobuf-method) stream)
 679   (print-unreadable-object (m stream :type t :identity t)
 680     (format stream "~S (~S) => (~S)"
 681             (proto-class m) (proto-input-type m) (proto-output-type m))))