;; Process 'import' lines
-(defun process-imports (&rest imports)
+(defun process-imports (protobuf &rest imports)
"Imports all of the files given by 'imports'.
If the file is a .proto file, it first parses it and writes a .lisp file.
The .lisp file is the compiled and loaded."
(dolist (import imports)
- (let* ((base-file (pathname import))
- (proto-file (make-pathname :type "proto" :defaults base-file))
- (lisp-file (make-pathname :name (pathname-name base-file) :type "lisp"
- :defaults (or *compile-file-pathname* base-file)))
+ (let* ((base-path (if *compile-file-pathname*
+ (merge-pathnames (pathname import) *compile-file-pathname*)
+ (pathname import)))
+ (proto-file (make-pathname :type "proto" :defaults base-path))
+ (lisp-file (make-pathname :type "lisp" :defaults base-path))
(fasl-file (compile-file-pathname lisp-file))
(proto-date (and (probe-file proto-file)
(ignore-errors (file-write-date proto-file))))
(ignore-errors (file-write-date lisp-file))))
(fasl-date (and (probe-file fasl-file)
(ignore-errors (file-write-date fasl-file)))))
- (when (string= (pathname-type base-file) "proto")
+ (when (string= (pathname-type base-path) "proto")
;; The user asked to import a .proto file
;; If there's no .lisp file or an older .lisp file, parse the .proto file now
(cond ((not proto-date)
- (warn "Could not find the file to be imported ~A" proto-file))
+ (warn "Could not find the .proto file to be imported: ~A" proto-file))
((or (not lisp-date)
(< lisp-date proto-date))
(parse-protobuf-file proto-file lisp-file)
(setq lisp-date (file-write-date lisp-file)))))
;; Compile the .lisp file, if necessary
(cond ((not lisp-date)
- (unless (string= (pathname-type base-file) "proto")
- (warn "Could not find the file to be imported ~A" proto-file)))
+ (unless (string= (pathname-type base-path) "proto")
+ (warn "Could not find the .lisp file to be compiled: ~A" lisp-file)))
(t
(when (or (not fasl-date)
(< fasl-date lisp-date))
(setq fasl-file (compile-file lisp-file))
(setq fasl-date (file-write-date fasl-file)))
;; Now we can load the .fasl file
- (load fasl-file))))))
+ (load fasl-file)))
+ (let ((imported (find-protobuf base-path)))
+ (when imported
+ (setf (proto-imported-schemas protobuf)
+ (nconc (proto-imported-schemas protobuf) (list imported)))))
+ base-path)))
(*protobuf-package* (or (find-package lisp-pkg)
(find-package (string-upcase lisp-pkg))
*package*)))
- (apply #'process-imports imports)
+ (apply #'process-imports protobuf imports)
(with-collectors ((forms collect-form))
(dolist (msg messages)
(assert (and (listp msg)
;; (define-enum, define-message, define-extend, define-service),
;; followed by the Lisp model object created by the defining form,
;; followed by other defining forms (e.g., deftype, defclass)
- (destructuring-bind (&optional progn type model definers)
+ (destructuring-bind (&optional progn model-type model definers)
(macroexpand-1 msg env)
(assert (eq progn 'progn) ()
"The macroexpansion for ~S failed" msg)
(map () #'collect-form definers)
- (ecase type
+ (ecase model-type
((define-enum)
(setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list model))))
((define-message define-extend)
(message (make-instance 'protobuf-message
:class type
:name name
+ :parent *protobuf*
:alias-for alias-for
:conc-name (and conc-name (string conc-name))
:options options
(dolist (field fields)
(case (car field)
((define-enum define-message define-extend define-extension define-group)
- (destructuring-bind (&optional progn type model definers extra-field extra-slot)
+ (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
(macroexpand-1 field env)
(assert (eq progn 'progn) ()
"The macroexpansion for ~S failed" field)
(map () #'collect-form definers)
- (ecase type
+ (ecase model-type
((define-enum)
(setf (proto-enums message) (nconc (proto-enums message) (list model))))
((define-message define-extend)
'reader' is a Lisp slot reader function to use to get the value, instead of
using 'slot-value'; this is often used when aliasing an existing class.
'writer' is a Lisp slot writer function to use to set the value."
- (declare (ignore env))
(let* ((name (or name (class-name->proto type)))
(options (loop for (key val) on options by #'cddr
collect (make-instance 'protobuf-option
:extensions (copy-list (proto-extensions message))
:message-type :extends ;this message is an extension
:documentation documentation)))
+ (*protobuf* extends)
(index 0))
(assert message ()
"There is no message named ~A to extend" name)
(with-collectors ((forms collect-form))
(dolist (field fields)
(assert (not (member (car field)
- '(define-enum define-message define-extend define-extension define-group))) ()
- "The body of ~S can only contain field definitions" 'define-extend)
- (multiple-value-bind (field slot idx)
- (process-field field index :conc-name conc-name :alias-for alias-for)
- (assert (not (find (proto-index field) (proto-fields extends) :key #'proto-index)) ()
- "The field ~S overlaps with another field in ~S"
- (proto-value field) (proto-class extends))
- (assert (index-within-extensions-p idx message) ()
- "The index ~D is not in range for extending ~S"
- idx (proto-class message))
- (setq index idx)
- (when slot
- (let* ((inits (cdr slot))
- (sname (car slot))
- (stable (fintern "~A-VALUES" sname))
- (stype (getf inits :type))
- (reader (or (getf inits :accessor)
- (getf inits :reader)
- (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
- (symbol-package sname))))
- (writer (or (getf inits :writer)
- (intern (format nil "~A-~A" reader 'setter)
- (symbol-package sname))))
- (default (getf inits :initform)))
- ;; For the extended slots, each slot gets its own table
- ;; keyed by the object, which lets us avoid having a slot in each
- ;; instance that holds a table keyed by the slot name
- ;; Multiple 'define-extends' on the same class in the same image
- ;; will result in harmless redefinitions, so squelch the warnings
- (collect-form `(without-redefinition-warnings ()
- (let ((,stable (make-hash-table :test #'eq :weak t)))
- (defmethod ,reader ((object ,type))
- (gethash object ,stable ,default))
- (defmethod ,writer ((object ,type) value)
- (declare (type ,stype value))
- (setf (gethash object ,stable) value))
- ;; For Python compatibility
- (defmethod get-extension ((object ,type) (slot (eql ',sname)))
- (values (gethash object ,stable ,default)))
- (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
- (setf (gethash object ,stable) value))
- (defmethod has-extension ((object ,type) (slot (eql ',sname)))
- (multiple-value-bind (value foundp)
- (gethash object ,stable ,default)
- (declare (ignore value))
- foundp))
- (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
- (remhash object ,stable))
- (defsetf ,reader ,writer))))
- ;; This so that (de)serialization works
- (setf (proto-reader field) reader
- (proto-writer field) writer)))
- (setf (proto-message-type field) :extends) ;this field is an extension
- (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))))
+ '(define-enum define-message define-extend define-extension))) ()
+ "The body of ~S can only contain field and group definitions" 'define-extend)
+ (case (car field)
+ ((define-group)
+ (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
+ (macroexpand-1 field env)
+ (assert (eq progn 'progn) ()
+ "The macroexpansion for ~S failed" field)
+ (map () #'collect-form definers)
+ (ecase model-type
+ ((define-group)
+ (setf (proto-parent model) extends)
+ (setf (proto-messages extends) (nconc (proto-messages extends) (list model)))
+ (when extra-slot
+ ;;--- Fix all this duplicated code!
+ (let* ((inits (cdr extra-slot))
+ (sname (car extra-slot))
+ (stable (fintern "~A-VALUES" sname))
+ (stype (getf inits :type))
+ (reader (or (getf inits :accessor)
+ (getf inits :reader)
+ (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
+ (symbol-package sname))))
+ (writer (or (getf inits :writer)
+ (intern (format nil "~A-~A" reader 'setter)
+ (symbol-package sname))))
+ (default (getf inits :initform)))
+ (collect-form `(without-redefinition-warnings ()
+ (let ((,stable (make-hash-table :test #'eq :weak t)))
+ ,@(and reader `((defmethod ,reader ((object ,type))
+ (gethash object ,stable ,default))))
+ ,@(and writer `((defmethod ,writer ((object ,type) value)
+ (declare (type ,stype value))
+ (setf (gethash object ,stable) value))))
+ ;; For Python compatibility
+ (defmethod get-extension ((object ,type) (slot (eql ',sname)))
+ (values (gethash object ,stable ,default)))
+ (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
+ (setf (gethash object ,stable) value))
+ (defmethod has-extension ((object ,type) (slot (eql ',sname)))
+ (multiple-value-bind (value foundp)
+ (gethash object ,stable ,default)
+ (declare (ignore value))
+ foundp))
+ (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
+ (remhash object ,stable))
+ ,@(and writer `((defsetf ,reader ,writer))))))))
+ (setf (proto-message-type extra-field) :extends) ;this field is an extension
+ (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field)))
+ (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list extra-field)))))))
+ (otherwise
+ (multiple-value-bind (field slot idx)
+ (process-field field index :conc-name conc-name :alias-for alias-for)
+ (assert (not (find (proto-index field) (proto-fields extends) :key #'proto-index)) ()
+ "The field ~S overlaps with another field in ~S"
+ (proto-value field) (proto-class extends))
+ (assert (index-within-extensions-p idx message) ()
+ "The index ~D is not in range for extending ~S"
+ idx (proto-class message))
+ (setq index idx)
+ (when slot
+ (let* ((inits (cdr slot))
+ (sname (car slot))
+ (stable (fintern "~A-VALUES" sname))
+ (stype (getf inits :type))
+ (reader (or (getf inits :accessor)
+ (getf inits :reader)
+ (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
+ (symbol-package sname))))
+ (writer (or (getf inits :writer)
+ (intern (format nil "~A-~A" reader 'setter)
+ (symbol-package sname))))
+ (default (getf inits :initform)))
+ ;; For the extended slots, each slot gets its own table
+ ;; keyed by the object, which lets us avoid having a slot in each
+ ;; instance that holds a table keyed by the slot name
+ ;; Multiple 'define-extends' on the same class in the same image
+ ;; will result in harmless redefinitions, so squelch the warnings
+ ;;--- Maybe these methods need to be defined in 'define-message'?
+ (collect-form `(without-redefinition-warnings ()
+ (let ((,stable (make-hash-table :test #'eq :weak t)))
+ ,@(and reader `((defmethod ,reader ((object ,type))
+ (gethash object ,stable ,default))))
+ ,@(and writer `((defmethod ,writer ((object ,type) value)
+ (declare (type ,stype value))
+ (setf (gethash object ,stable) value))))
+ ;; For Python compatibility
+ (defmethod get-extension ((object ,type) (slot (eql ',sname)))
+ (values (gethash object ,stable ,default)))
+ (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
+ (setf (gethash object ,stable) value))
+ (defmethod has-extension ((object ,type) (slot (eql ',sname)))
+ (multiple-value-bind (value foundp)
+ (gethash object ,stable ,default)
+ (declare (ignore value))
+ foundp))
+ (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
+ (remhash object ,stable))
+ ,@(and writer `((defsetf ,reader ,writer))))))
+ ;; This so that (de)serialization works
+ (setf (proto-reader field) reader
+ (proto-writer field) writer)))
+ (setf (proto-message-type field) :extends) ;this field is an extension
+ (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))
+ (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))))
`(progn
define-extend
,extends
(dolist (field fields)
(case (car field)
((define-enum define-message define-extend define-extension define-group)
- (destructuring-bind (&optional progn type model definers extra-field extra-slot)
+ (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
(macroexpand-1 field env)
(assert (eq progn 'progn) ()
"The macroexpansion for ~S failed" field)
(map () #'collect-form definers)
- (ecase type
+ (ecase model-type
((define-enum)
(setf (proto-enums message) (nconc (proto-enums message) (list model))))
((define-message define-extend)
(defvar *all-protobufs* (make-hash-table :test #'equal)
"A table mapping names to 'protobuf' schemas.")
-(defun find-protobuf (name)
- "Given a name (a symbol or string), return the 'protobuf' schema having that name."
- (values (gethash name *all-protobufs*)))
+(defgeneric find-protobuf (name)
+ (:documentation
+ "Given a name (a symbol or string), return the 'protobuf' schema having that name."))
+
+(defmethod find-protobuf ((name symbol))
+ (values (gethash (keywordify name) *all-protobufs*)))
+
+(defmethod find-protobuf ((name string))
+ (values (gethash (string-upcase name) *all-protobufs*)))
+
+(defmethod find-protobuf ((path pathname))
+ "Given a pathname, return the 'protobuf' schema that came from that path."
+ (let ((path (make-pathname :type nil :defaults path)))
+ (values (gethash path *all-protobufs*))))
(defvar *all-messages* (make-hash-table :test #'equal)
"A table mapping Lisp class names to 'protobuf' messages.")
+(defgeneric find-message-for-class (class)
+ (:documentation
+ "Given a class or class name, return the message that globally has that name."))
+
(defmethod find-message-for-class (class)
"Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
(values (gethash class *all-messages*)))
:accessor proto-lisp-package
:initarg :lisp-package
:initform nil)
- (imports :type (list-of string) ;any imports
+ (imports :type (list-of string) ;the names of any imported schemas, as strings
:accessor proto-imports
:initarg :imports
:initform ())
+ (schemas :type (list-of protobuf) ;the names of any imported schemas, as pathnames
+ :accessor proto-imported-schemas
+ :initform ())
(enums :type (list-of protobuf-enum) ;the set of enum types
:accessor proto-enums
:initarg :enums
:initform ())
- (messages :type (list-of protobuf-message) ;the set of messages
+ (messages :type (list-of protobuf-message) ;all the messages within this protobuf
:accessor proto-messages
:initarg :messages
:initform ())
- (extenders :type (list-of protobuf-message) ;the set of extended messages
- :accessor proto-extenders
+ (extenders :type (list-of protobuf-message) ;the 'extend' messages in this protobuf
+ :accessor proto-extenders ;these precede unextended messages in 'find-message'
:initarg :extenders
:initform ())
(services :type (list-of protobuf-service)
(with-slots (class name) protobuf
(record-protobuf protobuf class name)))
-(defmethod record-protobuf ((protobuf protobuf) class name)
- (when class
- (setf (gethash class *all-protobufs*) protobuf))
+(defmethod record-protobuf ((protobuf protobuf) symbol name)
+ "Record all the names by which the Protobufs schema might be known."
+ (when symbol
+ (setf (gethash (keywordify symbol) *all-protobufs*) protobuf))
(when name
- (setf (gethash name *all-protobufs*) protobuf)))
+ (setf (gethash (string-upcase name) *all-protobufs*) protobuf))
+ (let ((path (or *compile-file-truename* *load-truename*)))
+ (when path
+ ;; Record the file from which the Protobufs schema came, sans file type
+ (setf (gethash (make-pathname :type nil :defaults path) *all-protobufs*) protobuf))))
(defmethod make-load-form ((p protobuf) &optional environment)
(with-slots (class name) p
(defmethod find-message ((protobuf protobuf) (type symbol))
;; Extended messages "shadow" non-extended ones
- (or (find type (proto-extenders protobuf) :key #'proto-class)
- (find type (proto-messages protobuf) :key #'proto-class)))
+ (labels ((find-it (proto)
+ (let ((message (or (find type (proto-extenders proto) :key #'proto-class)
+ (find type (proto-messages proto) :key #'proto-class))))
+ (when message
+ (return-from find-message message))
+ (map () #'find-it (proto-imported-schemas proto)))))
+ (find-it protobuf)))
(defmethod find-message ((protobuf protobuf) (type class))
(find-message protobuf (class-name type)))
-(defmethod find-message ((protobuf protobuf) (type string))
- (or (find type (proto-extenders protobuf) :key #'proto-name :test #'string=)
- (find type (proto-messages protobuf) :key #'proto-name :test #'string=)))
+(defmethod find-message ((protobuf protobuf) (name string))
+ (labels ((find-it (proto)
+ (let ((message (or (find name (proto-extenders proto) :key #'proto-name :test #'string=)
+ (find name (proto-messages proto) :key #'proto-name :test #'string=))))
+ (when message
+ (return-from find-message message))
+ (map () #'find-it (proto-imported-schemas proto)))))
+ (find-it protobuf)))
(defgeneric find-enum (protobuf type)
(:documentation
returns the Protobufs enum corresponding to the type."))
(defmethod find-enum ((protobuf protobuf) type)
- (find type (proto-enums protobuf) :key #'proto-class))
-
-(defmethod find-enum ((protobuf protobuf) (type string))
- (find type (proto-enums protobuf) :key #'proto-name :test #'string=))
+ (labels ((find-it (proto)
+ (let ((enum (find type (proto-enums protobuf) :key #'proto-class)))
+ (when enum
+ (return-from find-enum enum))
+ (map () #'find-it (proto-imported-schemas proto)))))
+ (find-it protobuf)))
+
+(defmethod find-enum ((protobuf protobuf) (name string))
+ (labels ((find-it (proto)
+ (let ((enum (find name (proto-enums protobuf) :key #'proto-name :test #'string=)))
+ (when enum
+ (return-from find-enum enum))
+ (map () #'find-it (proto-imported-schemas proto)))))
+ (find-it protobuf)))
;; We accept and store any option, but only act on a few: default, packed,
:accessor proto-enums
:initarg :enums
:initform ())
- (messages :type (list-of protobuf-message) ;the embedded messages
+ (messages :type (list-of protobuf-message) ;all the messages embedded in this one
:accessor proto-messages
:initarg :messages
:initform ())
- (extenders :type (list-of protobuf-message) ;the set of extended messages
- :accessor proto-extenders
+ (extenders :type (list-of protobuf-message) ;the 'extend' messages embedded in this one
+ :accessor proto-extenders ;these precede unextended messages in 'find-message'
:initarg :extenders
:initform ())
- (fields :type (list-of protobuf-field) ;the fields
- :accessor proto-fields
+ (fields :type (list-of protobuf-field) ;all the fields of this message
+ :accessor proto-fields ;this includes local ones and extended ones
:initarg :fields
:initform ())
- (extensions :type (list-of protobuf-extension) ;any extensions
+ (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
+ :accessor proto-extended-fields
+ :initform ())
+ (extensions :type (list-of protobuf-extension) ;any extension ranges
:accessor proto-extensions
:initarg :extensions
:initform ())
(defmethod find-message ((message protobuf-message) (type class))
(find-message message (class-name type)))
-(defmethod find-message ((message protobuf-message) (type string))
- (or (find type (proto-extenders message) :key #'proto-name :test #'string=)
- (find type (proto-messages message) :key #'proto-name :test #'string=)
- (find-message (proto-parent message) type)))
+(defmethod find-message ((message protobuf-message) (name string))
+ (or (find name (proto-extenders message) :key #'proto-name :test #'string=)
+ (find name (proto-messages message) :key #'proto-name :test #'string=)
+ (find-message (proto-parent message) name)))
(defmethod find-enum ((message protobuf-message) type)
(or (find type (proto-enums message) :key #'proto-class)
(find-enum (proto-parent message) type)))
-(defmethod find-enum ((message protobuf-message) (type string))
- (or (find type (proto-enums message) :key #'proto-name :test #'string=)
- (find-enum (proto-parent message) type)))
+(defmethod find-enum ((message protobuf-message) (name string))
+ (or (find name (proto-enums message) :key #'proto-name :test #'string=)
+ (find-enum (proto-parent message) name)))
(defgeneric find-field (message name)
(:documentation
(defgeneric has-extension (object slot)
(:documentation
- "Returns true iff the there is an extended slot named 'slot' in 'object'"))
+ "Returns true iff the there is an extended slot named 'slot' in 'object'")
+ ;; The only default method is for 'has-extension'
+ ;; It's an error to call the other three functions on a non-extendable object
+ (:method ((object standard-object) slot)
+ (declare (ignore slot))
+ nil))
(defgeneric clear-extension (object slot)
(:documentation
(eq (proto-message-type f) :extends))))
-;; An extension within a message
+;; An extension range within a message
(defclass protobuf-extension (abstract-protobuf)
((from :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
:accessor proto-extension-from
:accessor proto-extension-to
:initarg :to))
(:documentation
- "The model class that represents an extension with a Protobufs message."))
+ "The model class that represents an extension range within a Protobufs message."))
(defmethod make-load-form ((e protobuf-extension) &optional environment)
(make-load-form-saving-slots e :environment environment))
(return (coerce string 'string)))))
(defun unescape-char (stream)
+ "Parse the next \"escaped\" character from the stream."
(let ((ch (read-char stream nil)))
(assert (not (null ch)) ()
"End of stream reached while reading escaped character")
- (flet ((make-char (code)
- (assert (< code char-code-limit))
- (code-char code)))
- (case ch
- ((#\x)
- (let* ((d1 (digit-char-p (read-char stream) 16))
- (d2 (digit-char-p (read-char stream) 16)))
- (code-char (+ (* d1 16) d2))))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (if (not (digit-char-p (peek-char nil stream nil)))
- #\null
- (let* ((d1 (digit-char-p ch 8))
- (d2 (digit-char-p (read-char stream) 8))
- (d3 (digit-char-p (read-char stream) 8)))
- (code-char (+ (* d1 64) (* d2 8) d3)))))
- ((#\t) #\Tab)
- ((#\n) #\Newline)
- ((#\r) #\Return)
- ((#\f) #\Page)
- ((#\b) #\Backspace)
- ((#\a) (code-char 7))
- ((#\e) (code-char 27))
- (otherwise ch)))))
+ (case ch
+ ((#\x)
+ ;; Two hex digits
+ (let* ((d1 (digit-char-p (read-char stream) 16))
+ (d2 (digit-char-p (read-char stream) 16)))
+ (code-char (+ (* d1 16) d2))))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (if (not (digit-char-p (peek-char nil stream nil)))
+ #\null
+ ;; Three octal digits
+ (let* ((d1 (digit-char-p ch 8))
+ (d2 (digit-char-p (read-char stream) 8))
+ (d3 (digit-char-p (read-char stream) 8)))
+ (code-char (+ (* d1 64) (* d2 8) d3)))))
+ ((#\t) #\tab)
+ ((#\n) #\newline)
+ ((#\r) #\return)
+ ((#\f) #\page)
+ ((#\b) #\backspace)
+ ((#\a) #\bell)
+ ((#\e) #\esc)
+ (otherwise ch))))
+
+(defun escape-char (ch)
+ "The inverse of 'unescape-char', for printing."
+ (if (and (standard-char-p ch) (graphic-char-p ch))
+ ch
+ (case ch
+ ((#\null) "\\0")
+ ((#\tab) "\\t")
+ ((#\newline) "\\n")
+ ((#\return) "\\r")
+ ((#\page) "\\f")
+ ((#\backspace) "\\b")
+ ((#\bell) "\\a")
+ ((#\esc) "\\e")
+ (otherwise
+ (format nil "\\x~2,'0X" (char-code ch))))))
(defun parse-signed-int (stream)
"Parse the next token in the stream as an integer, then skip the following whitespace.
:direction :input
:external-format :utf-8
:element-type 'character)
- (parse-protobuf-from-stream stream
- :name (class-name->proto (pathname-name (pathname stream)))
- :class (kintern (pathname-name (pathname stream))))))
+ (let ((*compile-file-pathname* (pathname stream))
+ (*compile-file-truename* (truename stream)))
+ (parse-protobuf-from-stream stream
+ :name (class-name->proto (pathname-name (pathname stream)))
+ :class (kintern (pathname-name (pathname stream)))))))
;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
;; writing a sophisticated parser
(let ((import (prog1 (parse-string stream)
(expect-char stream terminator () "package")
(maybe-skip-comments stream))))
- (process-imports import)
+ (process-imports protobuf import)
(setf (proto-imports protobuf) (nconc (proto-imports protobuf) (list import)))))
(defun parse-proto-option (stream protobuf &optional (terminators '(#\;)))
:messages (copy-list (proto-messages message))
:fields (copy-list (proto-fields message))
:extensions (copy-list (proto-extensions message))
- :message-type :extends)))) ;this message is an extension
+ :message-type :extends))) ;this message is an extension
+ (*protobuf* extends))
(loop
(let ((token (parse-token stream)))
(when (null token)
(setf (proto-alias-for extends) (make-lisp-symbol alias))))
(return-from parse-proto-extend extends))
(cond ((member token '("required" "optional" "repeated") :test #'string=)
- (parse-proto-field stream extends token message))
+ (let ((field (parse-proto-field stream extends token message)))
+ (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))
((string= token "option")
(parse-proto-option stream extends))
(t
:index idx
:default default
:packed (and packed (boolean-true-p packed))
- :message-type (proto-message-type message))))
+ :message-type (proto-message-type message)
+ :options opts)))
(when extended-from
(assert (index-within-extensions-p idx extended-from) ()
"The index ~D is not in range for extending ~S"
(format stream "~&~@[~VT~]// ~A~%"
(and (not (zerop indentation)) indentation) line))))
-(defvar *lisp-options* '(("lisp_package" "string" 195801)
- ("lisp_name" "string" 195802)
- ("lisp_alias" "string" 195803)
- ("lisp_type" "string" 195804)
- ("lisp_class" "string" 195805)
- ("lisp_slot" "string" 195806)))
-
-(defvar *option-types* '(("optimize_for" symbol)
+;; Lisp was born in 1958 :-)
+(defvar *lisp-options* '(("lisp_package" string 195801)
+ ("lisp_name" string 195802)
+ ("lisp_alias" string 195803)
+ ("lisp_type" string 195804)
+ ("lisp_class" string 195805)
+ ("lisp_slot" string 195806)))
+
+(defvar *option-types* '(("optimize_for" symbol)
+ ("deprecated" symbol)
("cc_generic_services" symbol)
("java_generic_services" symbol)
- ("py_generic_services" symbol)))
+ ("py_generic_services" symbol)
+ ("ctype" symbol)))
(defmethod write-protobuf-header ((type (eql :proto)) stream)
(format stream "~&import \"net/proto2/proto/descriptor.proto\";~%~%")
(format stream "~&extend proto2.MessageOptions {~%")
(loop for (option type index) in *lisp-options* doing
- (format stream "~& optional ~A ~A = ~D;~%" type option index))
+ (format stream "~& optional ~(~A~) ~A = ~D;~%" type option index))
(format stream "~&}~%~%"))
(defun cl-user::protobuf-option (stream option colon-p atsign-p)
(format stream "~&~VToption ~:/protobuf-option/;~%"
(+ indentation 2) option))
(cond ((eq message-type :extends)
- (loop for (field . more) on (proto-fields message) doing
- (when (eq (proto-message-type field) :extends)
- (write-protobuf-as type field stream
- :indentation (+ indentation 2) :more more
- :message message))))
+ (loop for (field . more) on (proto-extended-fields message) doing
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message)))
(t
(loop for (enum . more) on (proto-enums message) doing
(write-protobuf-as type enum stream :indentation (+ indentation 2) :more more))
(with-prefixed-accessors (name documentation required type index packed) (proto- field)
(let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
(msg (and (not (keywordp class))
- (or (find-message message class) (find-enum message class)))))
+ (or (find-message message class) (find-enum message class))))
+ (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default")
+ (string= (proto-name x) "packed")))
+ (proto-options field))))
(cond ((and (typep msg 'protobuf-message)
(eq (proto-message-type msg) :group))
(format stream "~&~@[~VT~]~(~A~) "
((typep msg 'protobuf-enum)
(let ((default (let ((e (find (proto-default field) (proto-values msg) :key #'proto-name :test #'string=)))
(and e (proto-name e)))))
- (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed = true]~*~];~:[~*~*~;~VT// ~A~]~%"
+ (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~:[~*~*~;~VT// ~A~]~%"
(and (not (zerop indentation)) indentation)
- required type name index default packed
+ required type name index default packed options
documentation *protobuf-field-comment-column* documentation)))
(t
- (let ((default (if (eq class :bool)
- (and (proto-default field)
- (if (boolean-true-p (proto-default field)) "true" "false"))
- (proto-default field))))
+ (let* ((default (if (eq class :bool)
+ (and (proto-default field)
+ (if (boolean-true-p (proto-default field)) "true" "false"))
+ (proto-default field)))
+ (default (if (stringp default) (escape-string default) default)))
(format stream (if (eq class :bool)
- "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~(~A~)]~]~@[ [packed = true]~*~];~:[~*~*~;~VT// ~A~]~%"
- "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~S]~]~@[ [packed = true]~*~];~:[~*~*~;~VT// ~A~]~%")
+ "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~(~A~)]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~:[~*~*~;~VT// ~A~]~%"
+ "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~:[~*~*~;~VT// ~A~]~%")
(and (not (zerop indentation)) indentation)
- required type name index default packed
+ required type name index default packed options
documentation *protobuf-field-comment-column* documentation)))))))
+(defun escape-string (string)
+ (if (every #'(lambda (ch) (and (standard-char-p ch) (graphic-char-p ch))) string)
+ string
+ (with-output-to-string (s)
+ (loop for ch across string
+ as esc = (escape-char ch)
+ do (format s "~A" esc)))))
+
(defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
&key (indentation 0) more)
(declare (ignore more))
(with-prefixed-accessors (from to) (proto-extension- extension)
- (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
+ (format stream "~&~@[~VT~]extensions ~D~:[~*~; to ~D~];~%"
(and (not (zerop indentation)) indentation)
- from (if (eql to #.(1- (ash 1 29))) "max" to))))
+ from (not (eql from to)) (if (eql to #.(1- (ash 1 29))) "max" to))))
(defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
*package*))
(*package* *protobuf-package*))
(when (or lisp-pkg pkg)
- (format stream "~&(in-package \"~A\")~%~%" (string-upcase (or lisp-pkg pkg))))
+ (let ((pkg (string-upcase (or lisp-pkg pkg))))
+ (format stream "~&(eval-when (:execute :compile-toplevel :load-toplevel) ~
+ ~% (unless (find-package \"~A\") ~
+ ~% (defpackage ~A))) ~
+ ~%(in-package \"~A\")~%~%"
+ pkg pkg pkg)))
(when documentation
(write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&(proto:define-proto ~(~A~)" (or class name))
(t
(format stream " ()"))))
(cond ((eq message-type :extends)
- (loop for (field . more) on (proto-fields message) doing
- (when (eq (proto-message-type field) :extends)
- (write-protobuf-as type field stream
- :indentation (+ indentation 2) :more more
- :message message)
- (when more
- (terpri stream)))))
+ (loop for (field . more) on (proto-extended-fields message) doing
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message)
+ (when more
+ (terpri stream))))
(t
(loop for (enum . more) on (proto-enums message) doing
(write-protobuf-as type enum stream :indentation (+ indentation 2) :more more)
`(or null ,cl))
((eq required :repeated)
`(list-of ,cl))
- (t cl)))))
+ (t cl))))
+ (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default")
+ (string= (proto-name x) "packed")))
+ (proto-options field))))
(cond ((and (typep msg 'protobuf-message)
(eq (proto-message-type msg) :group))
(write-protobuf-as :lisp msg stream :indentation indentation :index index :arity required))
((and (eq class :bool) defaultp)
(boolean-true-p default))
(t default)))
+ (default (if (stringp default) (escape-string default) default))
(slot (if *show-lisp-field-indexes*
(format nil "(~(~S~) ~D)" value index)
(format nil "~(~S~)" value))))
(format stream (if (and (keywordp class) (not (eq class :bool)))
;; Keyword means a primitive type, print default with ~S
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
- ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]"
+ ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :options (~{~@/protobuf-option/~^ ~})~])~
+ ~:[~*~*~;~VT; ~A~]"
;; Non-keyword must mean an enum type, print default with ~(~S~)
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
- ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]")
+ ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :options (~{~@/protobuf-option/~^ ~})~])~
+ ~:[~*~*~;~VT; ~A~]")
(and (not (zerop indentation)) indentation)
- slot type defaultp default reader writer
+ slot type defaultp default reader writer options
;; Don't write the comment if we'll insert a close paren after it
(and more documentation) *protobuf-slot-comment-column* documentation)))))))
"PROTO-ENUMS"
"PROTO-EXTENSION-FROM"
"PROTO-EXTENSION-TO"
+ "PROTO-EXTENDED-FIELDS"
"PROTO-EXTENDERS"
"PROTO-EXTENSIONS"
"PROTO-FIELDS"
"PROTO-FUNCTION"
+ "PROTO-IMPORTED-SCHEMAS"
"PROTO-IMPORTS"
"PROTO-INDEX"
"PROTO-INPUT-NAME"
(declare (dynamic-extent format-args))
(intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD"))
+(defun keywordify (x)
+ "Given a symbol designator 'x', return a keyword whose name is 'x'.
+ If 'x' is nil, this returns nil."
+ (check-type x (or string symbol null))
+ (cond ((null x) nil)
+ ((keywordp x) x)
+ ((symbolp x) (keywordify (symbol-name x)))
+ ((zerop (length x)) nil)
+ ((string-not-equal x "nil")
+ (intern (string-upcase x) (find-package "KEYWORD")))
+ (t nil)))
;;; Collectors, etc
projects / cl-protobufs.git / commitdiff