parser.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, 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          (skip-whitespace stream)
  85          (return-from maybe-skip-comments))
  86         (otherwise
  87          (error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
  88                 #\/ (file-position 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                   (if (eql (peek-char nil stream nil) ch0)
 160                     ;; If the next character is a quote character, that means
 161                     ;; we should go parse another string and concatenate it
 162                     (return (strcat (coerce string 'string) (parse-string stream)))
 163                     (return (coerce string 'string))))))
 164
 165 (defun unescape-char (stream)
 166   "Parse the next \"escaped\" character from the stream."
 167   (let ((ch (read-char stream nil)))
 168     (assert (not (null ch)) ()
 169             "End of stream reached while reading escaped character")
 170     (case ch
 171       ((#\x)
 172        ;; Two hex digits
 173        (let* ((d1 (digit-char-p (read-char stream) 16))
 174               (d2 (digit-char-p (read-char stream) 16)))
 175          (code-char (+ (* d1 16) d2))))
 176       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
 177        (if (not (digit-char-p (peek-char nil stream nil)))
 178          #\null
 179          ;; Three octal digits
 180          (let* ((d1 (digit-char-p ch 8))
 181                 (d2 (digit-char-p (read-char stream) 8))
 182                 (d3 (digit-char-p (read-char stream) 8)))
 183            (code-char (+ (* d1 64) (* d2 8) d3)))))
 184       ((#\t) #\tab)
 185       ((#\n) #\newline)
 186       ((#\r) #\return)
 187       ((#\f) #\page)
 188       ((#\b) #\backspace)
 189       ((#\a) #\bell)
 190       ((#\e) #\esc)
 191       (otherwise ch))))
 192
 193 (defun escape-char (ch)
 194   "The inverse of 'unescape-char', for printing."
 195   (if (and (standard-char-p ch) (graphic-char-p ch))
 196     ch
 197     (case ch
 198       ((#\null)      "\\0")
 199       ((#\tab)       "\\t")
 200       ((#\newline)   "\\n")
 201       ((#\return)    "\\r")
 202       ((#\page)      "\\f")
 203       ((#\backspace) "\\b")
 204       ((#\bell)      "\\a")
 205       ((#\esc)       "\\e")
 206       (otherwise
 207        (format nil "\\x~2,'0X" (char-code ch))))))
 208
 209 (defun parse-signed-int (stream)
 210   "Parse the next token in the stream as an integer, then skip the following whitespace.
 211    The returned value is the integer."
 212   (let* ((sign (if (eql (peek-char nil stream nil) #\-)
 213                  (progn (read-char stream) -1)
 214                  1))
 215          (int  (parse-unsigned-int stream)))
 216     (* int sign)))
 217
 218 (defun parse-unsigned-int (stream)
 219   "Parse the next token in the stream as an integer, then skip the following whitespace.
 220    The returned value is the integer."
 221   (when (digit-char-p (peek-char nil stream nil))
 222     (loop for ch = (read-char stream nil)
 223           for ch1 = (peek-char nil stream nil)
 224           collect ch into token
 225           until (or (null ch1) (and (not (digit-char-p ch1)) (not (eql ch #\x))))
 226           finally (progn
 227                     (skip-whitespace stream)
 228                     (let ((token (coerce token 'string)))
 229                       (if (starts-with token "0x")
 230                         (let ((*read-base* 16))
 231                           (return (parse-integer (subseq token 2))))
 232                         (return (parse-integer token))))))))
 233
 234 (defun parse-float (stream)
 235   "Parse the next token in the stream as a float, then skip the following whitespace.
 236    The returned value is the float."
 237   (let ((number (parse-number stream)))
 238     (when number
 239       (coerce number 'float))))
 240
 241 (defun parse-number (stream)
 242   (when (let ((ch (peek-char nil stream nil)))
 243           (or (digit-char-p ch) (member ch '(#\- #\+ #\.))))
 244     (let ((token (parse-token stream '(#\- #\+ #\.))))
 245       (when token
 246         (skip-whitespace stream)
 247         (parse-numeric-string token)))))
 248
 249 (defun parse-numeric-string (string)
 250   (cond ((starts-with string "0x")
 251          (parse-integer (subseq string 2) :radix 16))
 252         ((starts-with string "-0x")
 253          (- (parse-integer (subseq string 3) :radix 16)))
 254         (t
 255          (read-from-string string))))
 256
 257
 258 ;;; The parser itself
 259
 260 (defun parse-schema-from-file (filename &key name class (conc-name ""))
 261   "Parses the named file as a .proto file, and returns the Protobufs schema."
 262   (with-open-file (stream filename
 263                    :direction :input
 264                    :external-format :utf-8
 265                    :element-type 'character)
 266     (let ((*protobuf-pathname* (pathname stream))
 267           (*compile-file-pathname* (pathname stream))
 268           (*compile-file-truename* (truename stream)))
 269       (parse-schema-from-stream stream
 270                                 :name  (or name (class-name->proto (pathname-name (pathname stream))))
 271                                 :class (or class (kintern (pathname-name (pathname stream))))
 272                                 :conc-name conc-name))))
 273
 274 ;; 'with-proto-source-location' counts on this being a 3-element list
 275 ;; Yeah, it's a kludge, but we really don't need anything complicated for this
 276 (defstruct (source-location (:type list) (:constructor %make-source-location))
 277   pathname
 278   start-pos
 279   end-pos)
 280
 281 (defun make-source-location (stream start end)
 282   "Create a \"source locator\" for the stream at the current position.
 283    With any luck, we can get meta-dot to pay attention to it."
 284   (declare (ignore stream))
 285   ;; Don't record source locations if we're not parsing from a file
 286   (and *protobuf-pathname*
 287        (%make-source-location :pathname *protobuf-pathname*
 288                               :start-pos start :end-pos end)))
 289
 290 (defgeneric resolve-lisp-names (protobuf)
 291   (:documentation
 292    "Second pass of schema parsing which recursively resolves Protobuf type names
 293     to Lisp type names in all messages and services contained within 'protobuf'.
 294     No return value."))
 295
 296 ;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
 297 ;; writing a sophisticated parser
 298 ;; Note that we don't put the result into *all-schemas*; that's done in 'define-schema'
 299 (defun parse-schema-from-stream (stream &key name class (conc-name ""))
 300   "Parses a top-level .proto file from the stream 'stream'.
 301    Returns the protobuf schema that describes the .proto file."
 302   (let* ((schema (make-instance 'protobuf-schema
 303                    :class class
 304                    :name  name))
 305          (*protobuf* schema)
 306          *protobuf-package*
 307          *protobuf-rpc-package*
 308          (*protobuf-conc-name* conc-name))
 309     (labels ((ensure-package ()
 310                "Find a fallback for our Lisp package if we don't have an obvious one already.
 311                 * java_package
 312                 * *package*"
 313                (unless *protobuf-package*
 314                  (let ((java-package (find-option schema "java_package")))
 315                    (if java-package
 316                        (set-lisp-package schema java-package)
 317                        (setq *protobuf-package* *package*)))))
 318              (ensure-rpc-package ()
 319                (ensure-package)
 320                (unless *protobuf-rpc-package*
 321                  (let ((rpc-package-name (format nil "~A-~A" (package-name *protobuf-package*) 'rpc)))
 322                    (setq *protobuf-rpc-package*
 323                          (or (find-proto-package rpc-package-name)
 324                              (make-package (string-upcase rpc-package-name) :use ())))))))
 325       (loop
 326         (skip-whitespace stream)
 327         (maybe-skip-comments stream)
 328         (let ((char (peek-char nil stream nil)))
 329           (cond ((null char)
 330                  (remove-options schema "lisp_package")
 331                  (resolve-lisp-names schema)
 332                  (return-from parse-schema-from-stream schema))
 333                 ((proto-token-char-p char)
 334                  (let ((token (parse-token stream)))
 335                    (cond ((string= token "syntax")
 336                           (parse-proto-syntax stream schema))
 337                          ((string= token "package")
 338                           (parse-proto-package stream schema))
 339                          ((string= token "import")
 340                           (parse-proto-import stream schema))
 341                          ((string= token "option")
 342                           (let* ((option (parse-proto-option stream schema))
 343                                  (name   (and option (proto-name option)))
 344                                  (value  (and option (proto-value option))))
 345                             (when (and option (option-name= name "lisp_package"))
 346                               (set-lisp-package schema value))))
 347                          ((string= token "enum")
 348                           (ensure-package)
 349                           (parse-proto-enum stream schema))
 350                          ((string= token "extend")
 351                           (ensure-package)
 352                           (parse-proto-extend stream schema))
 353                          ((string= token "message")
 354                           (ensure-package)
 355                           (parse-proto-message stream schema))
 356                          ((string= token "service")
 357                           (ensure-rpc-package)
 358                           (parse-proto-service stream schema)))))
 359                 (t
 360                  (error "Syntax error at position ~D" (file-position stream)))))))))
 361
 362 (defun set-lisp-package (schema lisp-package-name)
 363   "Set the package for generated lisp names of 'schema'."
 364   (check-type schema protobuf-schema)
 365   (check-type lisp-package-name string)
 366   (let ((package (or (find-proto-package lisp-package-name)
 367                      ;; Try to put symbols into the right package
 368                      (make-package (string-upcase lisp-package-name) :use ())
 369                      *protobuf-package*)))
 370     (setf (proto-lisp-package schema) lisp-package-name)
 371     (setq *protobuf-package* package)))
 372
 373 (defmethod resolve-lisp-names ((schema protobuf-schema))
 374   "Recursively resolves Protobuf type names to Lisp type names in the messages and services in 'schema'."
 375   (map () #'resolve-lisp-names (proto-messages schema))
 376   (map () #'resolve-lisp-names (proto-services schema)))
 377
 378 (defun parse-proto-syntax (stream schema &optional (terminator #\;))
 379   "Parse a Protobufs syntax line from 'stream'.
 380    Updates the 'protobuf-schema' object to use the syntax."
 381   (let ((syntax (prog2 (expect-char stream #\= () "syntax")
 382                     (parse-string stream)
 383                   (expect-char stream terminator () "syntax")
 384                   (maybe-skip-comments stream))))
 385     (setf (proto-syntax schema) syntax)))
 386
 387 (defun parse-proto-package (stream schema &optional (terminator #\;))
 388   "Parse a Protobufs package line from 'stream'.
 389    Updates the 'protobuf-schema' object to use the package."
 390   (check-type schema protobuf-schema)
 391   (let* ((package  (prog1 (parse-token stream)
 392                      (expect-char stream terminator () "package")
 393                      (maybe-skip-comments stream)))
 394          (lisp-pkg (or (proto-lisp-package schema)
 395                        (substitute #\- #\_ package))))
 396     (setf (proto-package schema) package)
 397     (unless (proto-lisp-package schema)
 398       (set-lisp-package schema lisp-pkg))))
 399
 400 (defun parse-proto-import (stream schema &optional (terminator #\;))
 401   "Parse a Protobufs import line from 'stream'.
 402    Updates the 'protobuf-schema' object to use the import."
 403   (check-type schema protobuf-schema)
 404   (let ((import (prog1 (parse-string stream)
 405                   (expect-char stream terminator () "import")
 406                   (maybe-skip-comments stream))))
 407     (process-imports schema (list import))
 408     (setf (proto-imports schema) (nconc (proto-imports schema) (list import)))))
 409
 410 (defun parse-proto-option (stream protobuf &optional (terminators '(#\;)))
 411   "Parse a Protobufs option line from 'stream'.
 412    Updates the 'protobuf-schema' (or message, service, method) to have the option."
 413   (check-type protobuf (or null base-protobuf))
 414   (let* (terminator
 415          (key (prog1 (parse-parenthesized-token stream)
 416                 (expect-char stream #\= () "option")))
 417          (val (prog1 (let ((ch (peek-char nil stream nil)))
 418                        (cond ((eql ch #\")
 419                               (parse-string stream))
 420                              ((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
 421                               (parse-number stream))
 422                              ((eql ch #\{)
 423                               ;;---bwagner: This is incorrect
 424                               ;;   We need to find the field name in the locally-extended version of
 425                               ;;   google.protobuf.[File,Message,Field,Enum,EnumValue,Service,Method]Options
 426                               ;;   and get its type
 427                               (let ((message (find-message (or protobuf *protobuf*) key)))
 428                                 (if message
 429                                   ;; We've got a complex message as a value to an option
 430                                   ;; This only shows up in custom options
 431                                   (parse-text-format message :stream stream :parse-name nil)
 432                                   ;; Who knows what to do? Skip the value
 433                                   (skip-field stream))))
 434                              (t (kintern (parse-token stream)))))
 435                 (setq terminator (expect-char stream terminators () "option"))
 436                 (maybe-skip-comments stream)))
 437          (option (make-instance 'protobuf-option
 438                    :name  key
 439                    :value val)))
 440     (cond (protobuf
 441            (setf (proto-options protobuf) (nconc (proto-options protobuf) (list option)))
 442            (values option terminator))
 443           (t
 444            ;; If nothing to graft the option into, just return it as the value
 445            (values option terminator)))))
 446
 447
 448 (defun parse-proto-enum (stream protobuf)
 449   "Parse a Protobufs 'enum' from 'stream'.
 450    Updates the 'protobuf-schema' or 'protobuf-message' object to have the enum."
 451   (check-type protobuf (or protobuf-schema protobuf-message))
 452   (let* ((loc  (file-position stream))
 453          (name (prog1 (parse-token stream)
 454                  (expect-char stream #\{ () "enum")
 455                  (maybe-skip-comments stream)))
 456          (enum (make-instance 'protobuf-enum
 457                  :class (proto->class-name name *protobuf-package*)
 458                  :name name
 459                  :qualified-name (make-qualified-name protobuf name)
 460                  :parent protobuf
 461                  :source-location (make-source-location stream loc (i+ loc (length name))))))
 462     (loop
 463       (let ((name (parse-token stream)))
 464         (when (null name)
 465           (expect-char stream #\} '(#\;) "enum")
 466           (maybe-skip-comments stream)
 467           (setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list enum)))
 468           (let ((type (find-option enum "lisp_name")))
 469             (when type
 470               (setf (proto-class enum) (make-lisp-symbol type))))
 471           (let ((alias (find-option enum "lisp_alias")))
 472             (when alias
 473               (setf (proto-alias-for enum) (make-lisp-symbol alias))))
 474           (return-from parse-proto-enum enum))
 475         (if (string= name "option")
 476           (parse-proto-option stream enum)
 477           (parse-proto-enum-value stream protobuf enum name))))))
 478
 479 (defun parse-proto-enum-value (stream protobuf enum name)
 480   "Parse a Protobufs enum value from 'stream'.
 481    Updates the 'protobuf-enum' object to have the enum value."
 482   (declare (ignore protobuf))
 483   (check-type enum protobuf-enum)
 484   (expect-char stream #\= () "enum")
 485   (let* ((idx  (prog1 (parse-signed-int stream)
 486                  (expect-char stream #\; () "enum")
 487                  (maybe-skip-comments stream)))
 488          (value (make-instance 'protobuf-enum-value
 489                   :name  name
 490                   :qualified-name (make-qualified-name enum name)
 491                   :index idx
 492                   :value (proto->enum-name name *protobuf-package*)
 493                   :parent enum)))
 494     (setf (proto-values enum) (nconc (proto-values enum) (list value)))
 495     value))
 496
 497
 498 (defun parse-proto-message (stream protobuf &optional name)
 499   "Parse a Protobufs 'message' from 'stream'.
 500    Updates the 'protobuf-schema' or 'protobuf-message' object to have the message."
 501   (check-type protobuf (or protobuf-schema protobuf-message))
 502   (let* ((loc  (file-position stream))
 503          (name (prog1 (or name (parse-token stream))
 504                  (expect-char stream #\{ () "message")
 505                  (maybe-skip-comments stream)))
 506          (class (proto->class-name name *protobuf-package*))
 507          (message (make-instance 'protobuf-message
 508                     :class class
 509                     :name  name
 510                     :qualified-name (make-qualified-name protobuf name)
 511                     :parent protobuf
 512                     ;; Maybe force accessors for all slots
 513                     :conc-name (conc-name-for-type class *protobuf-conc-name*)
 514                     :source-location (make-source-location stream loc (i+ loc (length name)))))
 515          (*protobuf* message))
 516     (loop
 517       (let ((token (parse-token stream)))
 518         (when (null token)
 519           (expect-char stream #\} '(#\;) "message")
 520           (maybe-skip-comments stream)
 521           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list message)))
 522           (let ((type (find-option message "lisp_name")))
 523             (when type
 524               (setf (proto-class message) (make-lisp-symbol type))))
 525           (let ((alias (find-option message "lisp_alias")))
 526             (when alias
 527               (setf (proto-alias-for message) (make-lisp-symbol alias))))
 528           (return-from parse-proto-message message))
 529         (cond ((string= token "enum")
 530                (parse-proto-enum stream message))
 531               ((string= token "extend")
 532                (parse-proto-extend stream message))
 533               ((string= token "message")
 534                (parse-proto-message stream message))
 535               ((member token '("required" "optional" "repeated") :test #'string=)
 536                (parse-proto-field stream message token))
 537               ((string= token "option")
 538                (parse-proto-option stream message))
 539               ((string= token "extensions")
 540                (parse-proto-extension stream message))
 541               (t
 542                (error "Unrecognized token ~A at position ~D"
 543                       token (file-position stream))))))))
 544
 545 (defmethod resolve-lisp-names ((message protobuf-message))
 546   "Recursively resolves protobuf type names to lisp type names in nested messages and fields of 'message'."
 547   (map () #'resolve-lisp-names (proto-messages message))
 548   (map () #'resolve-lisp-names (proto-fields message)))
 549
 550 (defun parse-proto-extend (stream protobuf)
 551   "Parse a Protobufs 'extend' from 'stream'.
 552    Updates the 'protobuf-schema' or 'protobuf-message' object to have the message."
 553   (check-type protobuf (or protobuf-schema protobuf-message))
 554   (let* ((loc  (file-position stream))
 555          (name (prog1 (parse-token stream)
 556                  (expect-char stream #\{ () "extend")
 557                  (maybe-skip-comments stream)))
 558          ;;---bwagner: Is 'extend' allowed to use a forward reference to a message?
 559          (message (find-message protobuf name))
 560          (extends (and message
 561                        (make-instance 'protobuf-message
 562                          :class (proto-class message)
 563                          :name  (proto-name message)
 564                          :qualified-name (proto-qualified-name message)
 565                          :parent protobuf
 566                          :alias-for (proto-alias-for message)
 567                          :conc-name (proto-conc-name message)
 568                          :enums    (copy-list (proto-enums message))
 569                          :messages (copy-list (proto-messages message))
 570                          :fields   (copy-list (proto-fields message))
 571                          :extensions (copy-list (proto-extensions message))
 572                          :message-type :extends         ;this message is an extension
 573                          :source-location (make-source-location stream loc (i+ loc (length name))))))
 574          (*protobuf* extends))
 575     (assert message ()
 576             "There is no message named ~A to extend" name)
 577     (loop
 578       (let ((token (parse-token stream)))
 579         (when (null token)
 580           (expect-char stream #\} '(#\;) "extend")
 581           (maybe-skip-comments stream)
 582           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list extends)))
 583           (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list extends)))
 584           (let ((type (find-option extends "lisp_name")))
 585             (when type
 586               (setf (proto-class extends) (make-lisp-symbol type))))
 587           (let ((alias (find-option extends "lisp_alias")))
 588             (when alias
 589               (setf (proto-alias-for extends) (make-lisp-symbol alias))))
 590           (return-from parse-proto-extend extends))
 591         (cond ((member token '("required" "optional" "repeated") :test #'string=)
 592                (let ((field (parse-proto-field stream extends token message)))
 593                  (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))
 594               ((string= token "option")
 595                (parse-proto-option stream extends))
 596               (t
 597                (error "Unrecognized token ~A at position ~D"
 598                       token (file-position stream))))))))
 599
 600 (defun parse-proto-field (stream message required &optional extended-from)
 601   "Parse a Protobufs field from 'stream'.
 602    Updates the 'protobuf-message' object to have the field."
 603   (check-type message protobuf-message)
 604   (let ((type (parse-token stream)))
 605     (if (string= type "group")
 606       (parse-proto-group stream message required extended-from)
 607       (let* ((name (prog1 (parse-token stream)
 608                      (expect-char stream #\= () "message")))
 609              (idx  (parse-unsigned-int stream))
 610              (opts (prog1 (parse-proto-field-options stream)
 611                      (expect-char stream #\; () "message")
 612                      (maybe-skip-comments stream)))
 613              (packed (find-option opts "packed"))
 614              (slot   (proto->slot-name name *protobuf-package*))
 615              (reqd   (kintern required))
 616              (field  (make-instance 'protobuf-field
 617                        :name  name
 618                        :type  type
 619                        :qualified-name (make-qualified-name message name)
 620                        :parent message
 621                        ;; One of :required, :optional or :repeated
 622                        :required reqd
 623                        :index idx
 624                        :value slot
 625                        ;; Fields parsed from .proto files usually get an accessor
 626                        :reader (let ((conc-name (proto-conc-name message)))
 627                                  (and conc-name
 628                                       (intern (format nil "~A~A" conc-name slot) *protobuf-package*)))
 629                        :default (multiple-value-bind (default type default-p)
 630                                     (find-option opts "default")
 631                                   (declare (ignore type))
 632                                   (if default-p
 633                                     default
 634                                     (if (eq reqd :repeated) $empty-list $empty-default)))
 635                        :packed  (and packed (boolean-true-p packed))
 636                        :message-type (proto-message-type message)
 637                        :options (remove-options opts "default" "packed"))))
 638         (when extended-from
 639           (assert (index-within-extensions-p idx extended-from) ()
 640                   "The index ~D is not in range for extending ~S"
 641                   idx (proto-class extended-from)))
 642         (let ((slot (find-option opts "lisp_name")))
 643           (when slot
 644             (setf (proto-value field) (make-lisp-symbol type))))
 645         (setf (proto-fields message) (nconc (proto-fields message) (list field)))
 646         field))))
 647
 648 (defmethod resolve-lisp-names ((field protobuf-field))
 649   "Resolves the field's protobuf type to a lisp type and sets `proto-class' for 'field'."
 650   (let* ((type  (proto-type field))
 651          (ptype (when (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
 652                                      "fixed32" "fixed64" "sfixed32" "sfixed64"
 653                                      "string" "bytes" "bool" "float" "double") :test #'string=)
 654                   (kintern type)))
 655          (message (unless ptype
 656                     (or (find-message (proto-parent field) type)
 657                         (find-enum (proto-parent field) type)))))
 658     (unless (or ptype message)
 659       (error 'undefined-field-type
 660         :type-name type
 661         :field field))
 662     (setf (proto-class field) (or ptype (proto-class message))))
 663   nil)
 664
 665 (defun parse-proto-group (stream message required &optional extended-from)
 666   "Parse a (deprecated) Protobufs group from 'stream'.
 667    Updates the 'protobuf-message' object to have the group type and field."
 668   (check-type message protobuf-message)
 669   (let* ((type (prog1 (parse-token stream)
 670                  (expect-char stream #\= () "message")))
 671          (name (slot-name->proto (proto->slot-name type)))
 672          (idx  (parse-unsigned-int stream))
 673          (msg  (parse-proto-message stream message type))
 674          (slot  (proto->slot-name name *protobuf-package*))
 675          (field (make-instance 'protobuf-field
 676                   :name  name
 677                   :type  type
 678                   :qualified-name (make-qualified-name message name)
 679                   :parent message
 680                   :required (kintern required)
 681                   :index idx
 682                   :value slot
 683                   ;; Groups parsed from .proto files usually get an accessor
 684                   :reader (let ((conc-name (proto-conc-name message)))
 685                             (and conc-name
 686                                  (intern (format nil "~A~A" conc-name slot) *protobuf-package*)))
 687                   :message-type :group)))
 688     (setf (proto-message-type msg) :group)
 689     (when extended-from
 690       (assert (index-within-extensions-p idx extended-from) ()
 691               "The index ~D is not in range for extending ~S"
 692               idx (proto-class extended-from)))
 693     (setf (proto-fields message) (nconc (proto-fields message) (list field)))
 694     field))
 695
 696 (defun parse-proto-field-options (stream)
 697   "Parse any options in a Protobufs field from 'stream'.
 698    Returns a list of 'protobuf-option' objects."
 699   (with-collectors ((options collect-option))
 700     (let ((terminator nil))
 701       (loop
 702         (cond ((eql (peek-char nil stream nil) #\[)
 703                (expect-char stream #\[ () "message"))
 704               ((eql terminator #\,))
 705               (t
 706                (return-from parse-proto-field-options options)))
 707         (multiple-value-bind (option term)
 708             (parse-proto-option stream nil '(#\] #\,))
 709           (setq terminator term)
 710           (collect-option option))))))
 711
 712 (defun parse-proto-extension (stream message)
 713   (check-type message protobuf-message)
 714   (let* ((from  (parse-unsigned-int stream))
 715          (token (parse-token stream))
 716          (to    (let ((ch (peek-char nil stream nil)))
 717                   (cond ((digit-char-p (peek-char nil stream nil))
 718                          (parse-unsigned-int stream))
 719                         ((eql ch #\;) from)
 720                         (t (parse-token stream))))))
 721     (expect-char stream #\; () "message")
 722     (assert (or (null token) (string= token "to")) ()
 723             "Expected 'to' in 'extensions' at position ~D" (file-position stream))
 724     (assert (or (integerp to) (string= to "max")) ()
 725             "Extension value is not an integer or 'max' as position ~D" (file-position stream))
 726     (let ((extension (make-instance 'protobuf-extension
 727                        :from from
 728                        :to   (if (integerp to) to #.(1- (ash 1 29))))))
 729       (setf (proto-extensions message)
 730             (nconc (proto-extensions message)
 731                    (list extension)))
 732       extension)))
 733
 734
 735 (defun parse-proto-service (stream schema)
 736   "Parse a Protobufs 'service' from 'stream'.
 737    Updates the 'protobuf-schema' object to have the service."
 738   (check-type schema protobuf-schema)
 739   (let* ((loc  (file-position stream))
 740          (name (prog1 (parse-token stream)
 741                  (expect-char stream #\{ () "service")
 742                  (maybe-skip-comments stream)))
 743          (service (make-instance 'protobuf-service
 744                     :class (proto->class-name name *protobuf-package*)
 745                     :name name
 746                     :qualified-name (make-qualified-name *protobuf* name)
 747                     :parent schema
 748                     :source-location (make-source-location stream loc (i+ loc (length name)))))
 749          (index 0))
 750     (loop
 751       (let ((token (parse-token stream)))
 752         (when (null token)
 753           (expect-char stream #\} '(#\;) "service")
 754           (maybe-skip-comments stream)
 755           (setf (proto-services schema) (nconc (proto-services schema) (list service)))
 756           (return-from parse-proto-service service))
 757         (cond ((string= token "option")
 758                (parse-proto-option stream service))
 759               ((string= token "rpc")
 760                (parse-proto-method stream service (iincf index)))
 761               (t
 762                (error "Unrecognized token ~A at position ~D"
 763                       token (file-position stream))))))))
 764
 765 (defmethod resolve-lisp-names ((service protobuf-service))
 766   "Recursively resolves protobuf type names to lisp type names for all methods of 'service'."
 767   (map () #'resolve-lisp-names (proto-methods service)))
 768
 769 (defun parse-proto-method (stream service index)
 770   "Parse a Protobufs method from 'stream'.
 771    Updates the 'protobuf-service' object to have the method."
 772   (check-type service protobuf-service)
 773   (let* ((loc  (file-position stream))
 774          (name (parse-token stream))
 775          (in   (prog2 (expect-char stream #\( () "service")
 776                    (parse-token stream)
 777                  (expect-char stream #\) () "service")))
 778          (ret  (parse-token stream))            ;should be "=>"
 779          (out  (prog2 (expect-char stream #\( () "service")
 780                    (parse-token stream)
 781                  (expect-char stream #\) () "service")))
 782          (opts (multiple-value-bind (opts bodyp)
 783                    (parse-proto-method-options stream)
 784                  (when (or (not bodyp) (eql (peek-char nil stream nil) #\;))
 785                    (expect-char stream #\; () "service"))
 786                  (maybe-skip-comments stream)
 787                  opts))
 788          (stub   (proto->class-name name *protobuf-package*))
 789          (method (make-instance 'protobuf-method
 790                    :class stub
 791                    :name  name
 792                    :qualified-name (make-qualified-name *protobuf* name)
 793                    :parent service
 794                    :input-name  in
 795                    :output-name out
 796                    :index index
 797                    :options opts
 798                    :source-location (make-source-location stream loc (i+ loc (length name))))))
 799     (assert (string= ret "returns") ()
 800             "Syntax error in 'message' at position ~D" (file-position stream))
 801     (let* ((name (find-option method "lisp_name"))
 802            (stub (or (and name (make-lisp-symbol name))
 803                      stub)))
 804       (setf (proto-class method) stub
 805             (proto-client-stub method) (intern (format nil "~A-~A" 'call stub) *protobuf-rpc-package*)
 806             (proto-server-stub method) (intern (format nil "~A-~A" stub 'impl) *protobuf-rpc-package*)))
 807     (let ((strm (find-option method "stream_type")))
 808       (when strm
 809         (setf (proto-streams-name method) strm)))
 810     (setf (proto-methods service) (nconc (proto-methods service) (list method)))
 811     method))
 812
 813 (defmethod resolve-lisp-names ((method protobuf-method))
 814   "Resolves input, output, and streams protobuf type names to lisp type names and sets
 815    `proto-input-type', `proto-output-type', and, if `proto-streams-name' is set,
 816    `proto-streams-type' on 'method'."
 817   (let* ((input-name   (proto-input-name method))
 818          (output-name  (proto-output-name method))
 819          (streams-name (proto-streams-name method))
 820          (service (proto-parent method))
 821          (schema  (proto-parent service))
 822          (input-message   (find-message schema input-name))
 823          (output-message  (find-message schema output-name))
 824          (streams-message (and streams-name
 825                                ;; This is supposed to be the fully-qualified name,
 826                                ;; but we don't require that
 827                                (find-message schema streams-name))))
 828     (unless input-message
 829       (error 'undefined-input-type
 830         :type-name input-name
 831         :method method))
 832     (unless output-message
 833       (error 'undefined-output-type
 834         :type-name output-name
 835         :method method))
 836     (setf (proto-input-type method) (proto-class input-message))
 837     (setf (proto-output-type method) (proto-class output-message))
 838     (when streams-name
 839       (unless streams-message
 840         (error 'undefined-stream-type
 841           :type-name streams-name
 842           :method method))
 843       (setf (proto-streams-type method) (proto-class streams-message))))
 844   nil)
 845
 846 (defun parse-proto-method-options (stream)
 847   "Parse any options in a Protobufs method from 'stream'.
 848    Returns a list of 'protobuf-option' objects.
 849    If a body was parsed, returns a second value T."
 850   (when (eql (peek-char nil stream nil) #\{)
 851     (expect-char stream #\{ () "service")
 852     (maybe-skip-comments stream)
 853     (with-collectors ((options collect-option))
 854       (loop
 855         (when (eql (peek-char nil stream nil) #\})
 856           (return))
 857         (assert (string= (parse-token stream) "option") ()
 858                 "Syntax error in 'message' at position ~D" (file-position stream))
 859         (collect-option (parse-proto-option stream nil)))
 860       (expect-char stream #\} '(#\;) "service")
 861       (maybe-skip-comments stream)
 862       (values options t))))