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   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  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   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  26     (and ch (member ch '(#\return #\newline)))))
  27
  28 (declaim (inline proto-token-char-p))
  29 (defun proto-token-char-p (ch)
  30   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  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 ;;--- Collect the comment so we can attach it to its associated object
  43 (defun maybe-skip-comments (stream)
  44   "If what appears next in the stream is a comment, skip it and any following comments,
  45    then skip any following whitespace."
  46   (loop
  47     (unless (eql (peek-char nil stream nil) #\/)
  48       (return)
  49       (read-char stream)
  50       (case (peek-char nil stream nil)
  51         ((#\/)
  52          (skip-line-comment stream))
  53         ((#\*)
  54          (skip-block-comment stream))
  55         (otherwise
  56          (error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
  57                 #\/ (file-position stream) #\/ #\*)))))
  58   (skip-whitespace stream))
  59
  60 (defun skip-line-comment (stream)
  61   "Skip to the end of a line comment, that is, to the end of the line.
  62    Then skip any following whitespace."
  63   (loop for ch = (read-char stream nil)
  64         until (or (null ch) (proto-eol-char-p ch)))
  65   (skip-whitespace stream))
  66
  67 (defun skip-block-comment (stream)
  68   "Skip to the end of a block comment, that is, until a '*/' is seen.
  69    Then skip any following whitespace."
  70   (loop for ch = (read-char stream nil)
  71         do (cond ((null ch)
  72                   (error "Premature end of file while skipping block comment"))
  73                  ((and (eql ch #\*)
  74                        (eql (peek-char nil stream nil) #\/))
  75                   (read-char stream nil)
  76                   (return))))
  77   (skip-whitespace stream))
  78
  79
  80 (defun expect-char (stream ch &optional within)
  81   "Expect to see 'ch' as the next character in the stream; signal an error if it's not there.
  82    Then skip all of the following whitespace."
  83   (if (if (listp ch)
  84         (member (peek-char nil stream nil) ch)
  85         (eql (peek-char nil stream nil) ch))
  86     (read-char stream)
  87     (error "No '~C' found~@[ within '~A'~] at position ~D"
  88            ch within (file-position stream)))
  89   (skip-whitespace stream))
  90
  91
  92 (defun parse-token (stream)
  93   "Parse the next token in the stream, then skip the following whitespace.
  94    The returned value is the token."
  95   (when (proto-token-char-p (peek-char nil stream nil))
  96     (loop for ch = (read-char stream nil)
  97           for ch1 = (peek-char nil stream nil)
  98           collect ch into token
  99           until (or (null ch1) (not (proto-token-char-p ch1)))
 100           finally (progn
 101                     (skip-whitespace stream)
 102                     (return (coerce token 'string))))))
 103
 104 (defun parse-parenthesized-token (stream)
 105   "Parse the next token in the stream, then skip the following whitespace.
 106    The token might be surrounded by parentheses.
 107    The returned value is the token."
 108   (let ((left (peek-char nil stream nil)))
 109     (when (eq left #\()
 110       (read-char stream))
 111     (when (proto-token-char-p (peek-char nil stream nil))
 112       (loop for ch = (read-char stream nil)
 113             for ch1 = (peek-char nil stream nil)
 114             collect ch into token
 115             until (or (null ch1) (not (proto-token-char-p ch1)))
 116             finally (progn
 117                       (skip-whitespace stream)
 118                       (when (eq left #\()
 119                         (expect-char stream #\)))
 120                       (return (coerce token 'string)))))))
 121
 122 (defun parse-token-or-string (stream)
 123   (if (eql (peek-char nil stream nil) #\")
 124     (values (parse-string stream) 'string)
 125     (values (parse-token stream) 'symbol)))
 126
 127 (defun parse-string (stream)
 128   "Parse the next quoted string in the stream, then skip the following whitespace.
 129    The returned value is the string, without the quotation marks."
 130   (loop with ch0 = (read-char stream nil)
 131         for ch = (read-char stream nil)
 132         until (or (null ch) (char= ch ch0))
 133         collect ch into string
 134         finally (progn
 135                   (skip-whitespace stream)
 136                   (return (coerce string 'string)))))
 137
 138 (defun parse-int (stream)
 139   "Parse the next token in the stream as an integer, then skip the following whitespace.
 140    The returned value is the integer."
 141   (when (digit-char-p (peek-char nil stream nil))
 142     (loop for ch = (read-char stream nil)
 143           for ch1 = (peek-char nil stream nil)
 144           collect ch into token
 145           until (or (null ch1) (not (digit-char-p ch1)))
 146           finally (progn
 147                     (skip-whitespace stream)
 148                     (return (parse-integer (coerce token 'string)))))))
 149
 150 (defun parse-float (stream)
 151   "Parse the next token in the stream as a float, then skip the following whitespace.                                     The returned value is the float."
 152   (when (let ((ch (peek-char nil stream nil)))
 153             (or (digit-char-p ch) (eql ch #\-)))
 154     (let ((token (parse-token stream)))
 155       (when token
 156         (skip-whitespace stream)
 157         (coerce (read-from-string token) 'float)))))
 158
 159
 160 ;;; The parser itself
 161
 162 (defun parse-protobuf-from-file (filename)
 163   "Parses the named file as a .proto file, and returns the Protobufs schema."
 164   (with-open-file (stream filename
 165                    :direction :input
 166                    :external-format :utf-8
 167                    :element-type 'character)
 168     (parse-protobuf-from-stream stream
 169                                 :name  (class-name->proto (pathname-name (pathname stream)))
 170                                 :class (kintern (pathname-name (pathname stream))))))
 171
 172 ;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
 173 ;; writing a sophisticated parser
 174 ;; Note that we don't put the result into *all-protobufs*; do that at a higher level
 175 (defun parse-protobuf-from-stream (stream &key name class)
 176   "Parses a top-level .proto file from the stream 'stream'.
 177    Returns the protobuf schema that describes the .proto file."
 178   (let* ((protobuf (make-instance 'protobuf
 179                      :class class
 180                      :name  name))
 181          (*protobuf* protobuf)
 182          (*protobuf-package* nil))
 183     (loop
 184       (skip-whitespace stream)
 185       (maybe-skip-comments stream)
 186       (let ((char (peek-char nil stream nil)))
 187         (cond ((null char)
 188                (return-from parse-protobuf-from-stream protobuf))
 189               ((proto-token-char-p char)
 190                (let ((token (parse-token stream)))
 191                  (cond ((string= token "syntax")
 192                         (parse-proto-syntax stream protobuf))
 193                        ((string= token "package")
 194                         (parse-proto-package stream protobuf))
 195                        ((string= token "import")
 196                         (parse-proto-import stream protobuf))
 197                        ((string= token "option")
 198                         (let* ((option (parse-proto-option stream protobuf))
 199                                (name   (and option (proto-name option)))
 200                                (value  (and option (proto-value option))))
 201                           (when option
 202                             (cond ((option-name= name "optimize_for")
 203                                    (let ((value (cond ((string= value "SPEED") :speed)
 204                                                       ((string= value "CODE_SIZE") :space)
 205                                                       (t nil))))
 206                                      (setf (proto-optimize protobuf) value)))
 207                                   ((option-name= name "lisp_package")
 208                                    (let ((package (or (find-package value)
 209                                                       (find-package (string-upcase value)))))
 210                                      (setf (proto-lisp-package protobuf) value)
 211                                      (setq *protobuf-package* package)))))))
 212                        ((string= token "enum")
 213                         (parse-proto-enum stream protobuf))
 214                        ((string= token "extend")
 215                         (parse-proto-extend stream protobuf))
 216                        ((string= token "message")
 217                         (parse-proto-message stream protobuf))
 218                        ((string= token "service")
 219                         (parse-proto-service stream protobuf)))))
 220               (t
 221                (error "Syntax error at position ~D" (file-position stream))))))))
 222
 223 (defun parse-proto-syntax (stream protobuf &optional (terminator #\;))
 224   "Parse a Protobufs syntax line from 'stream'.
 225    Updates the 'protobuf' object to use the syntax."
 226   (let ((syntax (prog2 (expect-char stream #\= "syntax")
 227                     (parse-string stream)
 228                   (expect-char stream terminator "syntax")
 229                   (maybe-skip-comments stream))))
 230     (setf (proto-syntax protobuf) syntax)))
 231
 232 (defun parse-proto-package (stream protobuf &optional (terminator #\;))
 233   "Parse a Protobufs package line from 'stream'.
 234    Updates the 'protobuf' object to use the package."
 235   (check-type protobuf protobuf)
 236   (let* ((package  (prog1 (parse-token stream)
 237                      (expect-char stream terminator "package")
 238                      (maybe-skip-comments stream)))
 239          (lisp-pkg (or (proto-lisp-package protobuf)
 240                        (substitute #\- #\_ package))))
 241     (setf (proto-package protobuf) package)
 242     (unless (proto-lisp-package protobuf)
 243       (setf (proto-lisp-package protobuf) lisp-pkg))
 244     (let ((package (or (find-package lisp-pkg)
 245                        (find-package (string-upcase lisp-pkg)))))
 246       (setq *protobuf-package* package))))
 247
 248 (defun parse-proto-import (stream protobuf &optional (terminator #\;))
 249   "Parse a Protobufs import line from 'stream'.
 250    Updates the 'protobuf' object to use the package."
 251   (check-type protobuf protobuf)
 252   (let ((import (prog1 (parse-string stream)
 253                   (expect-char stream terminator "package")
 254                   (maybe-skip-comments stream))))
 255     (process-imports import)
 256     (setf (proto-imports protobuf) (nconc (proto-imports protobuf) (list import)))))
 257
 258 (defun parse-proto-option (stream protobuf &optional (terminator #\;))
 259   "Parse a Protobufs option line from 'stream'.
 260    Updates the 'protobuf' (or message, service, method) to have the option."
 261   (check-type protobuf (or null base-protobuf))
 262   (let* ((key (prog1 (parse-parenthesized-token stream)
 263                 (expect-char stream #\= "option")))
 264          (val (prog1 (if (eql (peek-char nil stream nil) #\")
 265                        (parse-string stream)
 266                        (parse-token stream))
 267                 (expect-char stream terminator "option")
 268                 (maybe-skip-comments stream)))
 269          (option (make-instance 'protobuf-option
 270                    :name  key
 271                    :value val)))
 272     (cond (protobuf
 273            (setf (proto-options protobuf) (nconc (proto-options protobuf) (list option)))
 274            option)
 275           (t
 276            ;; If nothing to graft the option into, just return it as the value
 277            option))))
 278
 279
 280 (defun parse-proto-enum (stream protobuf)
 281   "Parse a Protobufs 'enum' from 'stream'.
 282    Updates the 'protobuf' or 'protobuf-message' object to have the enum."
 283   (check-type protobuf (or protobuf protobuf-message))
 284   (let* ((name (prog1 (parse-token stream)
 285                  (expect-char stream #\{ "enum")
 286                  (maybe-skip-comments stream)))
 287          (enum (make-instance 'protobuf-enum
 288                  :class (proto->class-name name *protobuf-package*)
 289                  :name name)))
 290     (loop
 291       (let ((name (parse-token stream)))
 292         (when (null name)
 293           (expect-char stream #\} "enum")
 294           (maybe-skip-comments stream)
 295           (setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list enum)))
 296           (let ((type (find-option enum "lisp_name")))
 297             (when type
 298               (setf (proto-class enum) (make-lisp-symbol type))))
 299           (let ((alias (find-option enum "lisp_alias")))
 300             (when alias
 301               (setf (proto-alias-for enum) (make-lisp-symbol alias))))
 302           (return-from parse-proto-enum))
 303         (if (string= name "option")
 304           (parse-proto-option stream enum #\;)
 305           (parse-proto-enum-value stream enum name))))))
 306
 307 (defun parse-proto-enum-value (stream enum name)
 308   "Parse a Protobufs enum value from 'stream'.
 309    Updates the 'protobuf-enum' object to have the enum value."
 310   (check-type enum protobuf-enum)
 311   (expect-char stream #\= "enum")
 312   (let* ((idx  (prog1 (parse-int stream)
 313                  (expect-char stream #\; "enum")
 314                  (maybe-skip-comments stream)))
 315          (value (make-instance 'protobuf-enum-value
 316                   :name  name
 317                   :index idx
 318                   :value (proto->enum-name name *protobuf-package*))))
 319     (setf (proto-values enum) (nconc (proto-values enum) (list value)))))
 320
 321
 322 (defun parse-proto-message (stream protobuf)
 323   "Parse a Protobufs 'message' from 'stream'.
 324    Updates the 'protobuf' or 'protobuf-message' object to have the message."
 325   (check-type protobuf (or protobuf protobuf-message))
 326   (let* ((name (prog1 (parse-token stream)
 327                  (expect-char stream #\{ "message")
 328                  (maybe-skip-comments stream)))
 329          (message (make-instance 'protobuf-message
 330                     :class (proto->class-name name *protobuf-package*)
 331                     :name name
 332                     :parent protobuf))
 333          (*protobuf* message))
 334     (loop
 335       (let ((token (parse-token stream)))
 336         (when (null token)
 337           (expect-char stream #\} "message")
 338           (maybe-skip-comments stream)
 339           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list message)))
 340           (let ((type (find-option message "lisp_name")))
 341             (when type
 342               (setf (proto-class message) (make-lisp-symbol type))))
 343           (let ((alias (find-option message "lisp_alias")))
 344             (when alias
 345               (setf (proto-alias-for message) (make-lisp-symbol alias))))
 346           (return-from parse-proto-message))
 347         (cond ((string= token "enum")
 348                (parse-proto-enum stream message))
 349               ((string= token "extend")
 350                (parse-proto-extend stream message))
 351               ((string= token "message")
 352                (parse-proto-message stream message))
 353               ((member token '("required" "optional" "repeated") :test #'string=)
 354                (parse-proto-field stream message token))
 355               ((string= token "option")
 356                (parse-proto-option stream message #\;))
 357               ((string= token "extensions")
 358                (parse-proto-extension stream message))
 359               (t
 360                (error "Unrecognized token ~A at position ~D"
 361                       token (file-position stream))))))))
 362
 363 (defun parse-proto-extend (stream protobuf)
 364   "Parse a Protobufs 'extend' from 'stream'.
 365    Updates the 'protobuf' or 'protobuf-message' object to have the message."
 366   (check-type protobuf (or protobuf protobuf-message))
 367   (let* ((name (prog1 (parse-token stream)
 368                  (expect-char stream #\{ "extend")
 369                  (maybe-skip-comments stream)))
 370          (message (find-message *protobuf* name))
 371          (extends (and message
 372                        (make-instance 'protobuf-message
 373                          :class  (proto->class-name name *protobuf-package*)
 374                          :name   name
 375                          :parent (proto-parent message)
 376                          :conc-name (proto-conc-name message)
 377                          :alias-for (proto-alias-for message)
 378                          :enums    (copy-list (proto-enums message))
 379                          :messages (copy-list (proto-messages message))
 380                          :fields   (copy-list (proto-fields message))
 381                          :extension-p t))))             ;this message is an extension
 382     (loop
 383       (let ((token (parse-token stream)))
 384         (when (null token)
 385           (expect-char stream #\} "extend")
 386           (maybe-skip-comments stream)
 387           (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list extends)))
 388           (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list extends)))
 389           (let ((type (find-option extends "lisp_name")))
 390             (when type
 391               (setf (proto-class extends) (make-lisp-symbol type))))
 392           (let ((alias (find-option extends "lisp_alias")))
 393             (when alias
 394               (setf (proto-alias-for extends) (make-lisp-symbol alias))))
 395           (return-from parse-proto-extend))
 396         (cond ((member token '("required" "optional" "repeated") :test #'string=)
 397                (parse-proto-field stream extends token message))
 398               ((string= token "option")
 399                (parse-proto-option stream extends #\;))
 400               (t
 401                (error "Unrecognized token ~A at position ~D"
 402                       token (file-position stream))))))))
 403
 404 (defun parse-proto-field (stream message required &optional extended-from)
 405   "Parse a Protobufs field from 'stream'.
 406    Updates the 'protobuf-message' object to have the field."
 407   (check-type message protobuf-message)
 408   (let* ((type (parse-token stream))
 409          (name (prog1 (parse-token stream)
 410                  (expect-char stream #\= "message")))
 411          (idx  (parse-int stream))
 412          (opts (prog1 (parse-proto-field-options stream)
 413                  (expect-char stream #\; "message")
 414                  (maybe-skip-comments stream)))
 415          (dflt   (find-option opts "default"))
 416          (packed (find-option opts "packed"))
 417          (ptype  (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
 418                                     "fixed32" "fixed64" "sfixed32" "sfixed64"
 419                                     "string" "bytes" "bool" "float" "double") :test #'string=)
 420                    (kintern type)
 421                    type))
 422          (class  (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*)))
 423          (field  (make-instance 'protobuf-field
 424                    :name  name
 425                    :value (proto->slot-name name *protobuf-package*)
 426                    :type  type
 427                    :class class
 428                    ;; One of :required, :optional or :repeated
 429                    :required (kintern required)
 430                    :index idx
 431                    :default dflt
 432                    :packed  (and packed (string= packed "true"))
 433                    :extension-p (proto-extension-p message))))
 434     (when extended-from
 435       (assert (index-within-extensions-p idx extended-from) ()
 436               "The index ~D is not in range for extending ~S"
 437               idx (proto-class extended-from)))
 438     (let ((slot (find-option opts "lisp_name")))
 439       (when slot
 440         (setf (proto-value field) (make-lisp-symbol type))))
 441     (setf (proto-fields message) (nconc (proto-fields message) (list field)))))
 442
 443 (defun parse-proto-field-options (stream)
 444   "Parse any options in a Protobufs field from 'stream'.
 445    Returns a list of 'protobuf-option' objects."
 446   (with-collectors ((options collect-option))
 447     (loop
 448       (unless (eql (peek-char nil stream nil) #\[)
 449         (return-from parse-proto-field-options options))
 450       (expect-char stream #\[ "message")
 451       (collect-option (parse-proto-option stream nil #\])))
 452     options))
 453
 454 (defun parse-proto-extension (stream message)
 455   (check-type message protobuf-message)
 456   (let* ((from  (parse-int stream))
 457          (token (parse-token stream))
 458          (to    (if (digit-char-p (peek-char nil stream nil))
 459                   (parse-int stream)
 460                   (parse-token stream))))
 461     (expect-char stream #\; "message")
 462     (assert (string= token "to") ()
 463             "Expected 'to' in 'extensions' at position ~D" (file-position stream))
 464     (assert (or (integerp to) (string= to "max")) ()
 465             "Extension value is not an integer or 'max' as position ~D" (file-position stream))
 466     (setf (proto-extensions message)
 467           (nconc (proto-extensions message)
 468                  (list (make-instance 'protobuf-extension
 469                          :from from
 470                          :to   (if (integerp to) to #.(1- (ash 1 29)))))))))
 471
 472
 473 (defun parse-proto-service (stream protobuf)
 474   "Parse a Protobufs 'service' from 'stream'.
 475    Updates the 'protobuf-protobuf' object to have the service."
 476   (check-type protobuf protobuf)
 477   (let* ((name (prog1 (parse-token stream)
 478                  (expect-char stream #\{ "service")
 479                  (maybe-skip-comments stream)))
 480          (service (make-instance 'protobuf-service
 481                     :class (proto->class-name name *protobuf-package*)
 482                     :name name)))
 483     (loop
 484       (let ((token (parse-token stream)))
 485         (when (null token)
 486           (expect-char stream #\} "service")
 487           (maybe-skip-comments stream)
 488           (setf (proto-services protobuf) (nconc (proto-services protobuf) (list service)))
 489           (return-from parse-proto-service))
 490         (cond ((string= token "option")
 491                (parse-proto-option stream service #\;))
 492               ((string= token "rpc")
 493                (parse-proto-method stream service))
 494               (t
 495                (error "Unrecognized token ~A at position ~D"
 496                       token (file-position stream))))))))
 497
 498 (defun parse-proto-method (stream service)
 499   "Parse a Protobufs method from 'stream'.
 500    Updates the 'protobuf-service' object to have the method."
 501   (check-type service protobuf-service)
 502   (let* ((name (parse-token stream))
 503          (in   (prog2 (expect-char stream #\( "service")
 504                    (parse-token stream)
 505                  (expect-char stream #\) "service")))
 506          (ret  (parse-token stream))
 507          (out  (prog2 (expect-char stream #\( "service")
 508                    (parse-token stream)
 509                  (expect-char stream #\) "service")))
 510          (opts (let ((opts (parse-proto-method-options stream)))
 511                  (when (or (null opts) (eql (peek-char nil stream nil) #\;))
 512                    (expect-char stream #\; "service"))
 513                  (maybe-skip-comments stream)
 514                  opts))
 515          (method (make-instance 'protobuf-method
 516                    :class (proto->class-name name *protobuf-package*)
 517                    :name  name
 518                    :input-type  (proto->class-name in *protobuf-package*)
 519                    :input-name  in
 520                    :output-type (proto->class-name out *protobuf-package*)
 521                    :output-name out
 522                    :options opts)))
 523     (let ((name (find-option method "lisp_name")))
 524       (when name
 525         (setf (proto-function method) (make-lisp-symbol name))))
 526     (assert (string= ret "returns") ()
 527             "Syntax error in 'message' at position ~D" (file-position stream))
 528     (setf (proto-methods service) (nconc (proto-methods service) (list method)))))
 529
 530 (defun parse-proto-method-options (stream)
 531   "Parse any options in a Protobufs method from 'stream'.
 532    Returns a list of 'protobuf-option' objects."
 533   (when (eql (peek-char nil stream nil) #\{)
 534     (expect-char stream #\{ "service")
 535     (maybe-skip-comments stream)
 536     (with-collectors ((options collect-option))
 537       (loop
 538         (when (eql (peek-char nil stream nil) #\})
 539           (return))
 540         (assert (string= (parse-token stream) "option") ()
 541                 "Syntax error in 'message' at position ~D" (file-position stream))
 542         (collect-option (parse-proto-option stream nil #\;)))
 543       (expect-char stream #\} "service")
 544       (maybe-skip-comments stream)
 545       options)))