1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; .proto file parsing
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))))
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))))
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)
33 (member ch '(#\_ #\.)))))
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))))
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)))
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."
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)
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)
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)))
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."
80 (let ((ch (peek-char nil stream nil)))
81 (when (or (null ch) (not (eql ch #\/)))
82 (return-from maybe-skip-comments))
84 (case (peek-char nil stream nil)
86 (skip-line-comment stream))
88 (skip-block-comment stream))
90 (skip-whitespace stream)
91 (return-from maybe-skip-comments))
93 (error "Found a '~C' at ~A to start a comment, but no following '~C' or '~C'"
94 #\/ (parse-error-position stream) #\/ #\*))))))
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))
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)
108 (error "Premature end of file while skipping block comment"))
110 (eql (peek-char nil stream nil) #\/))
111 (read-char stream nil)
113 (skip-whitespace stream))
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
125 (and (not (proto-token-char-p ch1))
126 (not (member ch1 additional-chars))))
128 (skip-whitespace stream)
129 (return (coerce token 'string))))))
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)))
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)))
144 (skip-whitespace stream)
146 (expect-char stream #\)))
147 (return (coerce token 'string)))))))
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)))
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))
161 do (setq ch (unescape-char stream))
162 collect ch into string
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))))))
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")
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)))
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)))))
199 (defun escape-char (ch)
200 "The inverse of 'unescape-char', for printing."
201 (if (and (standard-char-p ch) (graphic-char-p ch))
209 ((#\backspace) "\\b")
213 (format nil "\\x~2,'0X" (char-code ch))))))
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)
221 (int (parse-unsigned-int stream)))
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))))
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))))))))
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)))
245 (coerce number 'float))))
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 '(#\- #\+ #\.))))
252 (skip-whitespace stream)
253 (parse-numeric-string token)))))
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)))
261 (read-from-string string))))
264 ;;; The parser itself
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
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))))
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))
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)))
296 (defgeneric resolve-lisp-names (protobuf)
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'.
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
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.
319 (unless *protobuf-package*
320 (let ((java-package (find-option schema "java_package")))
322 (set-lisp-package schema java-package)
323 (setq *protobuf-package* *package*)))))
324 (ensure-rpc-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 ())))))))
332 (skip-whitespace stream)
333 (maybe-skip-comments stream)
334 (let ((char (peek-char nil stream nil)))
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")
355 (parse-proto-enum stream schema))
356 ((string= token "extend")
358 (parse-proto-extend stream schema))
359 ((string= token "message")
361 (parse-proto-message stream schema))
362 ((string= token "service")
364 (parse-proto-service stream schema)))))
366 (error "Syntax error at ~A" (parse-error-position stream)))))))))
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)))
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)))
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)))
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))))
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))))
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))
421 (key (prog1 (parse-parenthesized-token stream)
422 (expect-char stream #\= () "option")))
423 (val (prog1 (let ((ch (peek-char nil stream nil)))
425 (parse-string stream))
426 ((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
427 (parse-number stream))
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
433 (let ((message (find-message (or protobuf *protobuf*) key)))
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)))
445 (appendf (proto-options protobuf) (list option))
446 (values option terminator))
448 ;; If nothing to graft the option into, just return it as the value
449 (values option terminator)))))
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*)
463 :qualified-name (make-qualified-name protobuf name)
465 :source-location (make-source-location stream loc (i+ loc (length name))))))
467 (let ((name (parse-token stream)))
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")))
474 (setf (proto-class enum) (make-lisp-symbol type))))
475 (let ((alias (find-option enum "lisp_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))))))
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
494 :qualified-name (make-qualified-name enum name)
496 :value (proto->enum-name name *protobuf-package*)
498 (appendf (proto-values enum) (list value))
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
514 :qualified-name (make-qualified-name protobuf name)
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))
521 (let ((token (parse-token stream)))
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")))
528 (setf (proto-class message) (make-lisp-symbol type))))
529 (let ((alias (find-option message "lisp_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))
546 (error "Unrecognized token ~A at ~A"
547 token (parse-error-position stream))))))))
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)))
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)
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))
580 "There is no message named ~A to extend" name)
582 (let ((token (parse-token stream)))
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")))
590 (setf (proto-class extends) (make-lisp-symbol type))))
591 (let ((alias (find-option extends "lisp_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))
601 (error "Unrecognized token ~A at ~A"
602 token (parse-error-position stream))))))))
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
623 :qualified-name (make-qualified-name message name)
625 ;; One of :required, :optional or :repeated
629 ;; Fields parsed from .proto files usually get an accessor
630 :reader (let ((conc-name (proto-conc-name message)))
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))
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"))))
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")))
648 (setf (proto-value field) (make-lisp-symbol type))))
649 (appendf (proto-fields message) (list field))
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=)
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
666 (setf (proto-class field) (or ptype (proto-class message))))
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
682 :qualified-name (make-qualified-name message name)
684 :required (kintern required)
687 ;; Groups parsed from .proto files usually get an accessor
688 :reader (let ((conc-name (proto-conc-name message)))
690 (intern (format nil "~A~A" conc-name slot) *protobuf-package*)))
691 :message-type :group)))
692 (setf (proto-message-type msg) :group)
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))
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))
706 (cond ((eql (peek-char nil stream nil) #\[)
707 (expect-char stream #\[ () "message"))
708 ((eql terminator #\,))
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))))))
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))
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
732 :to (if (integerp to) to #.(1- (ash 1 29))))))
733 (appendf (proto-extensions message) (list extension))
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*)
748 :qualified-name (make-qualified-name *protobuf* name)
750 :source-location (make-source-location stream loc (i+ loc (length name)))))
753 (let ((token (parse-token stream)))
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)))
764 (error "Unrecognized token ~A at ~A"
765 token (parse-error-position stream))))))))
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)))
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")
779 (expect-char stream #\) () "service")))
780 (ret (parse-token stream)) ;should be "=>"
781 (out (prog2 (expect-char stream #\( () "service")
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)
790 (stub (proto->class-name name *protobuf-package*))
791 (method (make-instance 'protobuf-method
794 :qualified-name (make-qualified-name *protobuf* name)
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))
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")))
811 (setf (proto-streams-name method) strm)))
812 (appendf (proto-methods service) (list method))
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
834 (unless output-message
835 (error 'undefined-output-type
836 :type-name output-name
838 (setf (proto-input-type method) (proto-class input-message))
839 (setf (proto-output-type method) (proto-class output-message))
841 (unless streams-message
842 (error 'undefined-stream-type
843 :type-name streams-name
845 (setf (proto-streams-type method) (proto-class streams-message))))
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))
857 (when (eql (peek-char nil stream nil) #\})
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))))