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