parser.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; .proto file parsing
  15
  16 ;;; Parsing utilities
  17
  18 (declaim (inline proto-whitespace-char-p))
  19 (defun proto-whitespace-char-p (ch)
  20   (declare #.$optimize-fast-unsafe)
  21   (and ch (member ch '(#\space #\tab #\return #\newline))))
  22
  23 (declaim (inline proto-eol-char-p))
  24 (defun proto-eol-char-p (ch)
  25   (declare #.$optimize-fast-unsafe)
  26   (and ch (member ch '(#\return #\newline))))
  27
  28 (declaim (inline proto-token-char-p))
  29 (defun proto-token-char-p (ch)
  30   (declare #.$optimize-fast-unsafe)
  31   (and ch (or (alpha-char-p ch)
  32               (digit-char-p ch)
  33               (member ch '(#\_ #\.)))))
  34
  35
  36 (defun skip-whitespace (stream)
  37   "Skip all the whitespace characters that are coming up in the stream."
  38   (loop for ch = (peek-char nil stream nil)
  39         until (or (null ch) (not (proto-whitespace-char-p ch)))
  40         do (read-char stream nil)))
  41
  42 (defun expect-char (stream char &optional chars within)
  43   "Expect to see 'char' as the next character in the stream; signal an error if it's not there.
  44    Then skip all of the following whitespace.
  45    The return value is the character that was eaten."
  46   (let (ch)
  47     (if (if (listp char)
  48           (member (peek-char nil stream nil) char)
  49           (eql (peek-char nil stream nil) char))
  50       (setq ch (read-char stream))
  51       (error "No '~C' found~@[ within '~A'~] at position ~D"
  52              char within (file-position stream)))
  53     (maybe-skip-chars stream chars)
  54     ch))
  55
  56 (defun maybe-skip-chars (stream chars)
  57   "Skip some optional characters in the stream,
  58    then skip all of the following whitespace."
  59   (skip-whitespace stream)
  60   (when chars
  61     (loop
  62       (let ((ch (peek-char nil stream nil)))
  63         (when (or (null ch) (not (member ch chars)))
  64           (skip-whitespace stream)
  65           (return-from maybe-skip-chars)))
  66       (read-char stream))))
  67
  68
  69 ;;--- Collect the comment so we can attach it to its associated object
  70 (defun maybe-skip-comments (stream)
  71   "If what appears next in the stream is a comment, skip it and any following comments,
  72    then skip any following whitespace."
  73   (loop
  74     (let ((ch (peek-char nil stream nil)))
  75       (when (or (null ch) (not (eql ch #\/)))
  76         (return-from maybe-skip-comments))
  77       (read-char stream)
  78       (case (peek-char nil stream nil)
  79         ((#\/)
  80          (skip-line-comment stream))
  81         ((#\*)
  82          (skip-block-comment stream))
  83         ((nil)
  84          (return-from maybe-skip-comments))
  85         (otherwise
  86          (error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
  87                 #\/ (file-position stream) #\/ #\*)))))
  88   (skip-whitespace stream))
  89
  90 (defun skip-line-comment (stream)
  91   "Skip to the end of a line comment, that is, to the end of the line.
  92    Then skip any following whitespace."
  93   (loop for ch = (read-char stream nil)
  94         until (or (null ch) (proto-eol-char-p ch)))
  95   (skip-whitespace stream))
  96
  97 (defun skip-block-comment (stream)
  98   "Skip to the end of a block comment, that is, until a '*/' is seen.
  99    Then skip any following whitespace."
 100   (loop for ch = (read-char stream nil)
 101         do (cond ((null ch)
 102                   (error "Premature end of file while skipping block comment"))
 103                  ((and (eql ch #\*)
 104                        (eql (peek-char nil stream nil) #\/))
 105                   (read-char stream nil)
 106                   (return))))
 107   (skip-whitespace stream))
 108
 109
 110 (defun parse-token (stream &optional additional-chars)
 111   "Parse the next token in the stream, then skip the following whitespace.
 112    The returned value is the token."
 113   (when (let ((ch (peek-char nil stream nil)))
 114           (or (proto-token-char-p ch) (member ch additional-chars)))
 115     (loop for ch = (read-char stream nil)
 116           for ch1 = (peek-char nil stream nil)
 117           collect ch into token
 118           until (or (null ch1)
 119                     (and (not (proto-token-char-p ch1))
 120                          (not (member ch1 additional-chars))))
 121           finally (progn
 122                     (skip-whitespace stream)
 123                     (return (coerce token 'string))))))
 124
 125 (defun parse-parenthesized-token (stream)
 126   "Parse the next token in the stream, then skip the following whitespace.
 127    The token might be surrounded by parentheses.
 128    The returned value is the token."
 129   (let ((left (peek-char nil stream nil)))
 130     (when (eql left #\()
 131       (read-char stream))
 132     (when (proto-token-char-p (peek-char nil stream nil))
 133       (loop for ch = (read-char stream nil)
 134             for ch1 = (peek-char nil stream nil)
 135             collect ch into token
 136             until (or (null ch1) (not (proto-token-char-p ch1)))
 137             finally (progn
 138                       (skip-whitespace stream)
 139                       (when (eql left #\()
 140                         (expect-char stream #\)))
 141                       (return (coerce token 'string)))))))
 142
 143 (defun parse-token-or-string (stream)
 144   (if (eql (peek-char nil stream nil) #\")
 145     (values (parse-string stream) 'string)
 146     (values (parse-token stream) 'symbol)))
 147
 148 (defun parse-string (stream)
 149   "Parse the next quoted string in the stream, then skip the following whitespace.
 150    The returned value is the string, without the quotation marks."
 151   (loop with ch0 = (read-char stream nil)
 152         for ch = (read-char stream nil)
 153         until (or (null ch) (char= ch ch0))
 154         when (eql ch #\\)
 155           do (setq ch (unescape-char stream))
 156         collect ch into string
 157         finally (progn
 158                   (skip-whitespace stream)
 159                   (return (coerce string 'string)))))
 160
 161 (defun unescape-char (stream)
 162   "Parse the next \"escaped\" character from the stream."
 163   (let ((ch (read-char stream nil)))
 164     (assert (not (null ch)) ()
 165             "End of stream reached while reading escaped character")
 166     (case ch
 167       ((#\x)
 168        ;; Two hex digits
 169        (let* ((d1 (digit-char-p (read-char stream) 16))
 170               (d2 (digit-char-p (read-char stream) 16)))
 171          (code-char (+ (* d1 16) d2))))
 172       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
 173        (if (not (digit-char-p (peek-char nil stream nil)))
 174          #\null
 175          ;; Three octal digits
 176          (let* ((d1 (digit-char-p ch 8))
 177                 (d2 (digit-char-p (read-char stream) 8))
 178                 (d3 (digit-char-p (read-char stream) 8)))
 179            (code-char (+ (* d1 64) (* d2 8) d3)))))
 180       ((#\t) #\tab)
 181       ((#\n) #\newline)
 182       ((#\r) #\return)
 183       ((#\f) #\page)
 184       ((#\b) #\backspace)
 185       ((#\a) #\bell)
 186       ((#\e) #\esc)
 187       (otherwise ch))))
 188
 189 (defun escape-char (ch)
 190   "The inverse of 'unescape-char', for printing."
 191   (if (and (standard-char-p ch) (graphic-char-p ch))
 192     ch
 193     (case ch
 194       ((#\null)      "\\0")
 195       ((#\tab)       "\\t")
 196       ((#\newline)   "\\n")
 197       ((#\return)    "\\r")
 198       ((#\page)      "\\f")
 199       ((#\backspace) "\\b")
 200       ((#\bell)      "\\a")
 201       ((#\esc)       "\\e")
 202       (otherwise
 203        (format nil "\\x~2,'0X" (char-code ch))))))
 204
 205 (defun parse-signed-int (stream)
 206   "Parse the next token in the stream as an integer, then skip the following whitespace.
 207    The returned value is the integer."
 208   (let* ((sign (if (eql (peek-char nil stream nil) #\-)
 209                  (progn (read-char stream) -1)
 210                  1))
 211          (int  (parse-unsigned-int stream)))
 212     (* int sign)))
 213
 214 (defun parse-unsigned-int (stream)
 215   "Parse the next token in the stream as an integer, then skip the following whitespace.
 216    The returned value is the integer."
 217   (when (digit-char-p (peek-char nil stream nil))
 218     (loop for ch = (read-char stream nil)
 219           for ch1 = (peek-char nil stream nil)
 220           collect ch into token
 221           until (or (null ch1) (and (not (digit-char-p ch1)) (not (eql ch #\x))))
 222           finally (progn
 223                     (skip-whitespace stream)
 224                     (let ((token (coerce token 'string)))
 225                       (if (starts-with token "0x")
 226                         (let ((*read-base* 16))
 227                           (return (parse-integer (subseq token 2))))
 228                         (return (parse-integer token))))))))
 229
 230 (defun parse-float (stream)
 231   "Parse the next token in the stream as a float, then skip the following whitespace.
 232    The returned value is the float."
 233   (let ((number (parse-number stream)))
 234     (when number
 235       (coerce number 'float))))
 236
 237 (defun parse-number (stream)
 238   (when (let ((ch (peek-char nil stream nil)))
 239           (or (digit-char-p ch) (member ch '(#\- #\+ #\.))))
 240     (let ((token (parse-token stream '(#\- #\+ #\.))))
 241       (when token
 242         (skip-whitespace stream)
 243         (parse-numeric-string token)))))
 244
 245 (defun parse-numeric-string (string)
 246   (cond ((starts-with string "0x")
 247          (parse-integer (subseq string 2) :radix 16))
 248         ((starts-with string "-0x")
 249          (- (parse-integer (subseq string 3) :radix 16)))
 250         (t
 251          (read-from-string string))))
 252
 253
 254 ;;; The parser itself
 255
 256 (defun parse-schema-from-file (filename &key name class (conc-name ""))
 257   "Parses the named file as a .proto file, and returns the Protobufs schema."
 258   (with-open-file (stream filename
 259                    :direction :input
 260                    :external-format :utf-8
 261                    :element-type 'character)
 262     (let ((*compile-file-pathname* (pathname stream))
 263           (*compile-file-truename* (truename stream)))
 264       (parse-schema-from-stream stream
 265                                   :name  (or name (class-name->proto (pathname-name (pathname stream))))
 266                                   :class (or class (kintern (pathname-name (pathname stream))))
 267                                   :conc-name conc-name))))
 268
 269 ;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
 270 ;; writing a sophisticated parser
 271 ;; Note that we don't put the result into *all-schemas*; that's done in 'define-schema'
 272 (defun parse-schema-from-stream (stream &key name class (conc-name ""))
 273   "Parses a top-level .proto file from the stream 'stream'.
 274    Returns the protobuf schema that describes the .proto file."
 275   (let* ((schema (make-instance 'protobuf-schema
 276                    :class class
 277                    :name  name))
 278          (*protobuf* schema)
 279          (*protobuf-package* *package*)
 280          (*protobuf-conc-name* conc-name))
 281     (loop
 282       (skip-whitespace stream)
 283       (maybe-skip-comments stream)
 284       (let ((char (peek-char nil stream nil)))
 285         (cond ((null char)
 286                (remove-options schema "lisp_package")
 287                (return-from parse-schema-from-stream schema))
 288               ((proto-token-char-p char)
 289                (let ((token (parse-token stream)))
 290                  (cond ((string= token "syntax")
 291                         (parse-proto-syntax stream schema))
 292                        ((string= token "package")
 293                         (parse-proto-package stream schema))
 294                        ((string= token "import")
 295                         (parse-proto-import stream schema))
 296                        ((string= token "option")
 297                         (let* ((option (parse-proto-option stream schema))
 298                                (name   (and option (proto-name option)))
 299                                (value  (and option (proto-value option))))
 300                           (when (and option (option-name= name "lisp_package"))
 301                             (let ((package (or (find-package value)
 302                                                (find-package (string-upcase value))
 303                                                *protobuf-package*)))
 304                               (setf (proto-lisp-package schema) value)
 305                               (setq *protobuf-package* package)))))
 306                        ((string= token "enum")
 307                         (parse-proto-enum stream schema))
 308                        ((string= token "extend")
 309                         (parse-proto-extend stream schema))
 310                        ((string= token "message")
 311                         (parse-proto-message stream schema))
 312                        ((string= token "service")
 313                         (parse-proto-service stream schema)))))
 314               (t
 315                (error "Syntax error at position ~D" (file-position stream))))))))
 316
 317 (defun parse-proto-syntax (stream schema &optional (terminator #\;))
 318   "Parse a Protobufs syntax line from 'stream'.
 319    Updates the 'protobuf-schema' object to use the syntax."
 320   (let ((syntax (prog2 (expect-char stream #\= () "syntax")
 321                     (parse-string stream)
 322                   (expect-char stream terminator () "syntax")
 323                   (maybe-skip-comments stream))))
 324     (setf (proto-syntax schema) syntax)))
 325
 326 (defun parse-proto-package (stream schema &optional (terminator #\;))
 327   "Parse a Protobufs package line from 'stream'.
 328    Updates the 'protobuf-schema' object to use the package."
 329   (check-type schema protobuf-schema)
 330   (let* ((package  (prog1 (parse-token stream)
 331                      (expect-char stream terminator () "package")
 332                      (maybe-skip-comments stream)))
 333          (lisp-pkg (or (proto-lisp-package schema)
 334                        (substitute #\- #\_ package))))
 335     (setf (proto-package schema) package)
 336     (unless (proto-lisp-package schema)
 337       (setf (proto-lisp-package schema) lisp-pkg))
 338     (let ((package (or (find-package lisp-pkg)
 339                        (find-package (string-upcase lisp-pkg))
 340                        *protobuf-package*)))
 341       (setq *protobuf-package* package))))
 342
 343 (defun parse-proto-import (stream schema &optional (terminator #\;))
 344   "Parse a Protobufs import line from 'stream'.
 345    Updates the 'protobuf-schema' object to use the package."
 346   (check-type schema protobuf-schema)
 347   (let ((import (prog1 (parse-string stream)
 348                   (expect-char stream terminator () "package")
 349                   (maybe-skip-comments stream))))
 350     (process-imports schema import)
 351     (setf (proto-imports schema) (nconc (proto-imports schema) (list import)))))
 352
 353 (defun parse-proto-option (stream protobuf &optional (terminators '(#\;)))
 354   "Parse a Protobufs option line from 'stream'.
 355    Updates the 'protobuf-schema' (or message, service, method) to have the option."
 356   (check-type protobuf (or null base-protobuf))
 357   (let* (terminator
 358          (key (prog1 (parse-parenthesized-token stream)
 359                 (expect-char stream #\= () "option")))
 360          (val (prog1 (let ((ch (peek-char nil stream nil)))
 361                        (cond ((eql ch #\")
 362                               (parse-string stream))
 363                              ((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
 364                               (parse-number stream))
 365                              (t (kintern (parse-token stream)))))
 366                 (setq terminator (expect-char stream terminators () "option"))
 367                 (maybe-skip-comments stream)))
 368          (option (make-instance 'protobuf-option
 369                    :name  key
 370                    :value val)))
 371     (cond (protobuf
 372            (setf (proto-options protobuf) (nconc (proto-options protobuf) (list option)))
 373            (values option terminator))
 374           (t
 375            ;; If nothing to graft the option into, just return it as the value
 376            (values option terminator)))))
 377
 378
 379 (defun parse-proto-enum (stream protobuf)
 380   "Parse a Protobufs 'enum' from 'stream'.
 381    Updates the 'protobuf-schema' or 'protobuf-message' object to have the enum."
 382   (check-type protobuf (or protobuf-schema protobuf-message))
 383   (let* ((name (prog1 (parse-token stream)
 384                  (expect-char stream #\{ () "enum")
 385                  (maybe-skip-comments stream)))
 386          (enum (make-instance 'protobuf-enum
 387                  :class (proto->class-name name *protobuf-package*)
 388                  :name name)))
 389     (loop
 390       (let ((name (parse-token stream)))
 391         (when (null name)
 392           (expect-char stream #\} '(#\;) "enum")
 393           (maybe-skip-comments stream)
 394           (setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list enum)))
 395           (let ((type (find-option enum "lisp_name")))
 396             (when type
 397               (setf (proto-class enum) (make-lisp-symbol type))))
 398           (let ((alias (find-option enum "lisp_alias")))
 399             (when alias
 400               (setf (proto-alias-for enum) (make-lisp-symbol alias))))
 401           (return-from parse-proto-enum enum))
 402         (if (string= name "option")
 403           (parse-proto-option stream enum)
 404           (parse-proto-enum-value stream enum name))))))
 405
 406 (defun parse-proto-enum-value (stream enum name)
 407   "Parse a Protobufs enum value from 'stream'.
 408    Updates the 'protobuf-enum' object to have the enum value."
 409   (check-type enum protobuf-enum)
 410   (expect-char stream #\= () "enum")
 411   (let* ((idx  (prog1 (parse-signed-int stream)
 412                  (expect-char stream #\; () "enum")
 413                  (maybe-skip-comments stream)))
 414          (value (make-instance 'protobuf-enum-value
 415                   :name  name
 416                   :index idx
 417                   :value (proto->enum-name name *protobuf-package*))))
 418     (setf (proto-values enum) (nconc (proto-values enum) (list value)))
 419     value))
 420
 421
 422 (defun parse-proto-message (stream protobuf &optional name)
 423   "Parse a Protobufs 'message' from 'stream'.
 424    Updates the 'protobuf-schema' or 'protobuf-message' object to have the message."
 425   (check-type protobuf (or protobuf-schema protobuf-message))
 426   (let* ((name (prog1 (or name (parse-token stream))
 427                  (expect-char stream #\{ () "message")
 428                  (maybe-skip-comments stream)))
 429          (message (make-instance 'protobuf-message
 430                     :class (proto->class-name name *protobuf-package*)
 431                     :name name
 432                     :parent protobuf
 433                     ;; Force accessors for all slots
 434                     :conc-name *protobuf-conc-name*))
 435          (*protobuf* message))
 436     (loop
 437       (let ((token (parse-token stream)))
 438         (when (null token)
 439           (expect-char stream #\} '(#\;) "message")
 440           (maybe-skip-comments stream)
 441           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list message)))
 442           (let ((type (find-option message "lisp_name")))
 443             (when type
 444               (setf (proto-class message) (make-lisp-symbol type))))
 445           (let ((alias (find-option message "lisp_alias")))
 446             (when alias
 447               (setf (proto-alias-for message) (make-lisp-symbol alias))))
 448           (return-from parse-proto-message message))
 449         (cond ((string= token "enum")
 450                (parse-proto-enum stream message))
 451               ((string= token "extend")
 452                (parse-proto-extend stream message))
 453               ((string= token "message")
 454                (parse-proto-message stream message))
 455               ((member token '("required" "optional" "repeated") :test #'string=)
 456                (parse-proto-field stream message token))
 457               ((string= token "option")
 458                (parse-proto-option stream message))
 459               ((string= token "extensions")
 460                (parse-proto-extension stream message))
 461               (t
 462                (error "Unrecognized token ~A at position ~D"
 463                       token (file-position stream))))))))
 464
 465 (defun parse-proto-extend (stream protobuf)
 466   "Parse a Protobufs 'extend' from 'stream'.
 467    Updates the 'protobuf-schema' or 'protobuf-message' object to have the message."
 468   (check-type protobuf (or protobuf-schema protobuf-message))
 469   (let* ((name (prog1 (parse-token stream)
 470                  (expect-char stream #\{ () "extend")
 471                  (maybe-skip-comments stream)))
 472          (message (find-message protobuf name))
 473          (extends (and message
 474                        (make-instance 'protobuf-message
 475                          :class  (proto->class-name name *protobuf-package*)
 476                          :name   name
 477                          :parent (proto-parent message)
 478                          :conc-name (proto-conc-name message)
 479                          :alias-for (proto-alias-for message)
 480                          :enums    (copy-list (proto-enums message))
 481                          :messages (copy-list (proto-messages message))
 482                          :fields   (copy-list (proto-fields message))
 483                          :extensions (copy-list (proto-extensions message))
 484                          :message-type :extends)))      ;this message is an extension
 485          (*protobuf* extends))
 486     (loop
 487       (let ((token (parse-token stream)))
 488         (when (null token)
 489           (expect-char stream #\} '(#\;) "extend")
 490           (maybe-skip-comments stream)
 491           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list extends)))
 492           (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list extends)))
 493           (let ((type (find-option extends "lisp_name")))
 494             (when type
 495               (setf (proto-class extends) (make-lisp-symbol type))))
 496           (let ((alias (find-option extends "lisp_alias")))
 497             (when alias
 498               (setf (proto-alias-for extends) (make-lisp-symbol alias))))
 499           (return-from parse-proto-extend extends))
 500         (cond ((member token '("required" "optional" "repeated") :test #'string=)
 501                (let ((field (parse-proto-field stream extends token message)))
 502                  (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))
 503               ((string= token "option")
 504                (parse-proto-option stream extends))
 505               (t
 506                (error "Unrecognized token ~A at position ~D"
 507                       token (file-position stream))))))))
 508
 509 (defun parse-proto-field (stream message required &optional extended-from)
 510   "Parse a Protobufs field from 'stream'.
 511    Updates the 'protobuf-message' object to have the field."
 512   (check-type message protobuf-message)
 513   (let ((type (parse-token stream)))
 514     (if (string= type "group")
 515       (parse-proto-group stream message required extended-from)
 516       (let* ((name (prog1 (parse-token stream)
 517                      (expect-char stream #\= () "message")))
 518              (idx  (parse-unsigned-int stream))
 519              (opts (prog1 (parse-proto-field-options stream)
 520                      (expect-char stream #\; () "message")
 521                      (maybe-skip-comments stream)))
 522              (packed (find-option opts "packed"))
 523              (ptype  (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
 524                                         "fixed32" "fixed64" "sfixed32" "sfixed64"
 525                                         "string" "bytes" "bool" "float" "double") :test #'string=)
 526                        (kintern type)
 527                        type))
 528              (class  (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*)))
 529              (slot   (proto->slot-name name *protobuf-package*))
 530              (reqd   (kintern required))
 531              (field  (make-instance 'protobuf-field
 532                        :name  name
 533                        :type  type
 534                        :class class
 535                        ;; One of :required, :optional or :repeated
 536                        :required reqd
 537                        :index idx
 538                        :value slot
 539                        ;; Fields parsed from .proto files usually get an accessor
 540                        :reader (and *protobuf-conc-name*
 541                                     (intern (format nil "~A~A" *protobuf-conc-name* slot) *protobuf-package*))
 542                        :default (multiple-value-bind (default type default-p)
 543                                     (find-option opts "default")
 544                                   (declare (ignore type))
 545                                   (if default-p
 546                                     default
 547                                     (if (eq reqd :repeated) $empty-list $empty-default)))
 548                        :packed  (and packed (boolean-true-p packed))
 549                        :message-type (proto-message-type message)
 550                        :options (remove-options opts "default" "packed"))))
 551         (when extended-from
 552           (assert (index-within-extensions-p idx extended-from) ()
 553                   "The index ~D is not in range for extending ~S"
 554                   idx (proto-class extended-from)))
 555         (let ((slot (find-option opts "lisp_name")))
 556           (when slot
 557             (setf (proto-value field) (make-lisp-symbol type))))
 558         (setf (proto-fields message) (nconc (proto-fields message) (list field)))
 559         field))))
 560
 561 (defun parse-proto-group (stream message required &optional extended-from)
 562   "Parse a (deprecated) Protobufs group from 'stream'.
 563    Updates the 'protobuf-message' object to have the group type and field."
 564   (check-type message protobuf-message)
 565   (let* ((type (prog1 (parse-token stream)
 566                  (expect-char stream #\= () "message")))
 567          (name (slot-name->proto (proto->slot-name type)))
 568          (idx  (parse-unsigned-int stream))
 569          (msg  (parse-proto-message stream message type))
 570          (class (proto->class-name type *protobuf-package*))
 571          (slot  (proto->slot-name name *protobuf-package*))
 572          (field (make-instance 'protobuf-field
 573                   :name  name
 574                   :type  type
 575                   :class class
 576                   :required (kintern required)
 577                   :index idx
 578                   :value slot
 579                   ;; Groups parsed from .proto files always get an accessor
 580                   :reader (and *protobuf-conc-name*
 581                                (intern (format nil "~A~A" *protobuf-conc-name* slot) *protobuf-package*))
 582                   :message-type :group)))
 583     (setf (proto-message-type msg) :group)
 584     (when extended-from
 585       (assert (index-within-extensions-p idx extended-from) ()
 586               "The index ~D is not in range for extending ~S"
 587               idx (proto-class extended-from)))
 588     (setf (proto-fields message) (nconc (proto-fields message) (list field)))
 589     field))
 590
 591 (defun parse-proto-field-options (stream)
 592   "Parse any options in a Protobufs field from 'stream'.
 593    Returns a list of 'protobuf-option' objects."
 594   (with-collectors ((options collect-option))
 595     (let ((terminator nil))
 596       (loop
 597         (cond ((eql (peek-char nil stream nil) #\[)
 598                (expect-char stream #\[ () "message"))
 599               ((eql terminator #\,))
 600               (t
 601                (return-from parse-proto-field-options options)))
 602         (multiple-value-bind (option term)
 603             (parse-proto-option stream nil '(#\] #\,))
 604           (setq terminator term)
 605           (collect-option option))))
 606     options))
 607
 608 (defun parse-proto-extension (stream message)
 609   (check-type message protobuf-message)
 610   (let* ((from  (parse-unsigned-int stream))
 611          (token (parse-token stream))
 612          (to    (let ((ch (peek-char nil stream nil)))
 613                   (cond ((digit-char-p (peek-char nil stream nil))
 614                          (parse-unsigned-int stream))
 615                         ((eql ch #\;) from)
 616                         (t (parse-token stream))))))
 617     (expect-char stream #\; () "message")
 618     (assert (or (null token) (string= token "to")) ()
 619             "Expected 'to' in 'extensions' at position ~D" (file-position stream))
 620     (assert (or (integerp to) (string= to "max")) ()
 621             "Extension value is not an integer or 'max' as position ~D" (file-position stream))
 622     (let ((extension (make-instance 'protobuf-extension
 623                        :from from
 624                        :to   (if (integerp to) to #.(1- (ash 1 29))))))
 625       (setf (proto-extensions message)
 626             (nconc (proto-extensions message)
 627                    (list extension)))
 628       extension)))
 629
 630
 631 (defun parse-proto-service (stream schema)
 632   "Parse a Protobufs 'service' from 'stream'.
 633    Updates the 'protobuf-schema' object to have the service."
 634   (check-type schema protobuf-schema)
 635   (let* ((name (prog1 (parse-token stream)
 636                  (expect-char stream #\{ () "service")
 637                  (maybe-skip-comments stream)))
 638          (service (make-instance 'protobuf-service
 639                     :class (proto->class-name name *protobuf-package*)
 640                     :name name))
 641          (index 0))
 642     (loop
 643       (let ((token (parse-token stream)))
 644         (when (null token)
 645           (expect-char stream #\} '(#\;) "service")
 646           (maybe-skip-comments stream)
 647           (setf (proto-services schema) (nconc (proto-services schema) (list service)))
 648           (return-from parse-proto-service service))
 649         (cond ((string= token "option")
 650                (parse-proto-option stream service))
 651               ((string= token "rpc")
 652                (parse-proto-method stream service (iincf index)))
 653               (t
 654                (error "Unrecognized token ~A at position ~D"
 655                       token (file-position stream))))))))
 656
 657 (defun parse-proto-method (stream service index)
 658   "Parse a Protobufs method from 'stream'.
 659    Updates the 'protobuf-service' object to have the method."
 660   (check-type service protobuf-service)
 661   (let* ((name (parse-token stream))
 662          (in   (prog2 (expect-char stream #\( () "service")
 663                    (parse-token stream)
 664                  (expect-char stream #\) () "service")))
 665          (ret  (parse-token stream))
 666          (out  (prog2 (expect-char stream #\( () "service")
 667                    (parse-token stream)
 668                  (expect-char stream #\) () "service")))
 669          (opts (let ((opts (parse-proto-method-options stream)))
 670                  (when (or (null opts) (eql (peek-char nil stream nil) #\;))
 671                    (expect-char stream #\; () "service"))
 672                  (maybe-skip-comments stream)
 673                  opts))
 674          (method (make-instance 'protobuf-method
 675                    :class (proto->class-name name *protobuf-package*)
 676                    :name  name
 677                    :input-type  (proto->class-name in *protobuf-package*)
 678                    :input-name  in
 679                    :output-type (proto->class-name out *protobuf-package*)
 680                    :output-name out
 681                    :index index
 682                    :options opts)))
 683     (let ((name (find-option method "lisp_name")))
 684       (when name
 685         (setf (proto-function method) (make-lisp-symbol name))))
 686     (assert (string= ret "returns") ()
 687             "Syntax error in 'message' at position ~D" (file-position stream))
 688     (setf (proto-methods service) (nconc (proto-methods service) (list method)))
 689     method))
 690
 691 (defun parse-proto-method-options (stream)
 692   "Parse any options in a Protobufs method from 'stream'.
 693    Returns a list of 'protobuf-option' objects."
 694   (when (eql (peek-char nil stream nil) #\{)
 695     (expect-char stream #\{ () "service")
 696     (maybe-skip-comments stream)
 697     (with-collectors ((options collect-option))
 698       (loop
 699         (when (eql (peek-char nil stream nil) #\})
 700           (return))
 701         (assert (string= (parse-token stream) "option") ()
 702                 "Syntax error in 'message' at position ~D" (file-position stream))
 703         (collect-option (parse-proto-option stream nil)))
 704       (expect-char stream #\} '(#\;) "service")
 705       (maybe-skip-comments stream)
 706       options)))