[ - 'find-message' and 'find-enum' need to search namespaces ]
[ if the quick compare against the name/class fails ]
- 'message Foo { message Bar { ... } ... }'
-- should (maybe!) produce a Lisp class defaultly named 'foo.bar'
++ should not produce a Lisp class defaultly named 'foo.bar', but...
- Add a keyword arg, :class-name, that overrides this convention;
in .proto files this should be called lisp_class
- Also, add :slot-name for slots and :type-name for enums
(called lisp_slot and lisp_type in .proto files)
-- - Or maybe not, since 'foo.bar' isn't very Lispy;
-- for the most part, packages provide enough room to avoid name clashes
++ - Rationale: 'foo.bar' isn't very Lispy;
++ for the most part, packages provide enough namespaces to avoid clashes
- Get 'merge-from-message' fully working
- See the place in 'deserialize-object' that needs to merge, too
[ - &key name should give the Protobufs name for the field ]
[ - 'option lisp_name="pkg:name"' should give the Lisp name for the slot ]
++- Refactor 'define-message'/'define-extend'/'define-group'
++ to avoid so much duplicated code
++
[- Need search paths in the ASDF .proto module ]
[- Make 'import' really work ]
(error 'compile-error
:component component :operation op)))))
- (append (output-files (make-instance 'compile-op) component) ; fasl
- (cdr (output-files (make-instance 'proto-to-lisp) component)))) ; proto-imports
+ (defmethod input-files ((op load-op) (component protobuf-file))
+ "The input files are the .fasl and .proto-imports files."
+ (declare (ignorable op))
++ (append (output-files (make-instance 'compile-op) component) ;fasl
++ (cdr (output-files (make-instance 'proto-to-lisp) component)))) ;proto-imports
+
+ (defmethod perform ((op load-op) (component protobuf-file))
+ (let* ((input (protobuf-input-file component))
+ (paths (cons (directory-namestring input) (resolve-search-path component)))
+ (proto-impl:*protobuf-search-path* paths)
+ (proto-impl:*protobuf-output-path* (first (input-files op component))))
+ (destructuring-bind (fasl proto-imports)
+ (input-files op component)
+ (proto-impl:process-imports-from-file proto-imports)
+ (load fasl))))
+
(defmethod operation-description ((op compile-op) (component protobuf-file))
(format nil (compatfmt "~@<compiling ~3i~_~A~@:>")
- (make-pathname :name (pathname-name (component-pathname component))
- :type "lisp"
- :defaults (first (output-files op component)))))
+ (first (input-files op component))))
\f
;;; Processing of imports
(setf (proto-imported-schemas schema)
(nconc (proto-imported-schemas schema) (list imported)))
(return-from import-one))
- (dolist (path search-path (error "Could not import ~S" import))
- (let* ((base-path (asdf::merge-pathnames* import path))
- (proto-file (make-pathname :name import-name :type "proto"
- :defaults base-path))
- (lisp-file (if output-path
- (make-pathname :name import-name :type "lisp"
- :directory (pathname-directory output-path))
- (make-pathname :type "lisp" :defaults base-path)))
- (fasl-file (compile-file-pathname lisp-file))
- (asdf:*asdf-verbose* nil) ;for safe-file-write-date
- (proto-date (asdf::safe-file-write-date proto-file))
- (lisp-date (asdf::safe-file-write-date lisp-file))
- (fasl-date (asdf::safe-file-write-date fasl-file)))
- (when (probe-file proto-file)
- (let ((*protobuf-pathname* proto-file))
- (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 .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-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))
- (let ((*compile-file-pathname* lisp-file)
- (*load-pathname* nil))
- (setq fasl-file (compile-file lisp-file)))
- (setq fasl-date (file-write-date fasl-file)))
- ;; Now we can load the .fasl file
- (let ((*compile-file-pathname* nil)
- (*load-pathname* fasl-file))
- (load fasl-file)))))
- (let* ((imported (find-schema base-path)))
- (when imported
- (setf (proto-imported-schemas schema)
- (nconc (proto-imported-schemas schema) (list imported))))
- (return-from import-one)))))))))
- (%process-import import import-name)
++ (do-process-import import import-name)
+ (let* ((imported (find-schema (class-name->proto import-name))))
+ (when imported
+ (setf (proto-imported-schemas schema)
+ (nconc (proto-imported-schemas schema) (list imported))))
+ (return-from import-one))))))
+
+ (defun process-imports-from-file (imports-file)
+ (when (probe-file imports-file)
+ (let ((imports (with-open-file (stream imports-file
+ :direction :input
+ :external-format :utf-8
+ :element-type 'character)
+ (with-standard-io-syntax (read stream)))))
+ (dolist (import imports)
+ (let* ((import (pathname import))
+ (import-name (pathname-name import)))
+ ;; If this schema has already been loaded, we're done.
+ (unless (find-schema (class-name->proto import-name))
- (%process-import import import-name)))))))
++ (do-process-import import import-name)))))))
+
-(defun %process-import (import import-name
- &key (search-path *protobuf-search-path*)
- (output-path *protobuf-output-path*))
++(defun do-process-import (import import-name
++ &key (search-path *protobuf-search-path*)
++ (output-path *protobuf-output-path*))
+ (dolist (path search-path (error "Could not import ~S" import))
+ (let* ((base-path (asdf::merge-pathnames* import path))
+ (proto-file (make-pathname :name import-name :type "proto"
+ :defaults base-path))
+ (lisp-file (asdf::lispize-pathname
+ (if output-path
+ (make-pathname :name import-name
+ :directory (pathname-directory output-path))
+ base-path)))
+ (imports-file (make-pathname :type "proto-imports"
+ :defaults lisp-file))
+ (fasl-file (compile-file-pathname lisp-file))
+ (asdf:*asdf-verbose* nil) ;for safe-file-write-date
+ (proto-date (asdf::safe-file-write-date proto-file))
+ (lisp-date (asdf::safe-file-write-date lisp-file))
+ (fasl-date (asdf::safe-file-write-date fasl-file))
+ (imports-date (asdf::safe-file-write-date imports-file)))
+ (when (probe-file proto-file)
+ (let ((*protobuf-pathname* proto-file))
+ (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, or no
+ ;; .proto-imports file or an older .proto-imports file parse
+ ;; the .proto file now
+ ;; If we did not parse the .proto file, process the generated
+ ;; .proto-imports file now.
+ (cond ((not proto-date)
+ (warn "Could not find the .proto file to be imported: ~A" proto-file))
+ ((or (not (and lisp-date imports-date))
+ (< lisp-date proto-date)
+ (< imports-date proto-date))
+ (parse-protobuf-file proto-file lisp-file imports-file)
+ (setq lisp-date (file-write-date lisp-file))
+ (setq imports-date (file-write-date imports-file)))
+ (t
+ (process-imports-from-file imports-file))))
+ ;; Compile the .lisp file, if necessary
+ (cond ((not lisp-date)
+ (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))
+ (let ((*compile-file-pathname* lisp-file)
+ (*load-pathname* nil))
+ (setq fasl-file (compile-file lisp-file)))
+ (setq fasl-date (file-write-date fasl-file)))))
+ ;; Load the .fasl file
+ (cond ((not fasl-date)
+ (unless (string= (pathname-type base-path) "proto")
+ (warn "Could not find the .fasl file to be loaded: ~A" fasl-file)))
+ (t
+ (let ((*compile-file-pathname* nil)
+ (*load-pathname* fasl-file))
+ (load fasl-file)))))
+ (return (values))))))
--- /dev/null
- :initarg :type-name
- :documentation "The name of the type which can not be found."))
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; ;;;
+ ;;; Free Software published under an MIT-like license. See LICENSE ;;;
+ ;;; ;;;
+ ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+ ;;; ;;;
+ ;;; Original author: Ben Wagner ;;;
+ ;;; ;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (in-package "PROTO-IMPL")
+
+ ;;; Protocol buffers conditions
+
+ (define-condition undefined-type (simple-error)
+ ((type-name :type string
+ :reader error-type-name
- (format stream "~? ~s"
++ :initarg :type-name))
+ (:documentation "Indicates that a schema references a type which has not been defined.")
+ (:default-initargs :format-control "Undefined type:")
+ (:report (lambda (condition stream)
- :initarg :field
- :documentation "The field whose type is TYPE-NAME."))
++ (format stream "~? ~S"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-type-name condition)))))
+
+ (define-condition undefined-field-type (undefined-type)
+ ((field :type protobuf-field
+ :reader error-field
- (format stream "~? Field ~s in message ~s has unknown type ~s."
++ :initarg :field))
+ (:documentation "Indicates that a schema contains a message with a field whose type is not a
+ primitive type and is not a known message (or extend) or enum.")
+ (:report (lambda (condition stream)
- :initarg :method
- :documentation "The method that references TYPE-NAME.")
++ (format stream "~? Field ~S in message ~S has unknown type ~S"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-field condition)
+ (proto-parent (error-field condition))
+ (error-type-name condition)))))
+
++;; The serializers use this a lot, so wrap it up
++(defun undefined-field-type (format-control object type field)
++ (error 'undefined-field-type
++ :format-control format-control
++ :format-arguments (list object)
++ :type-name (prin1-to-string type)
++ :field field))
++
+ (define-condition undefined-method-type (undefined-type)
+ ((method :type protobuf-method
+ :reader error-method
- (format stream "~? ~a type for rpc ~s in service ~s has unknown type ~s."
++ :initarg :method)
+ (where :type string
+ :reader error-where
+ :initarg :where
+ :documentation "Description of which type referenced by the method is undefined."))
+ (:documentation "Superclass for `undefined-type' errors related to a `protobuf-method'. Indicates
+ that a schema contains a service with a method whose input, output, or stream
+ type is not a known message (or extend).")
+ (:report (lambda (condition stream)
++ (format stream "~? ~A type for RPC ~S in service ~S has unknown type ~S"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-where condition)
+ (error-method condition)
+ (proto-parent (error-method condition))
+ (error-type-name condition)))))
+
+ (define-condition undefined-input-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Input"))
+
+ (define-condition undefined-output-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Output"))
+
+ (define-condition undefined-stream-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Stream"))
(t
(error "Syntax error at position ~D" (file-position stream))))))))
- "Recursively resolves protobuf type names to lisp type names in the messages and services in
- 'schema'."
+ (defun set-lisp-package (schema lisp-package-name)
+ "Set the package for generated lisp names of 'schema'."
+ (check-type schema protobuf-schema)
+ (check-type lisp-package-name string)
+ (let ((package (or (find-proto-package lisp-package-name)
+ ;; Try to put symbols into the right package
+ (make-package (string-upcase lisp-package-name) :use ())
+ *protobuf-package*)))
+ (setf (proto-lisp-package schema) lisp-package-name)
+ (setq *protobuf-package* package)))
+
+ (defmethod resolve-lisp-names ((schema protobuf-schema))
++ "Recursively resolves Protobuf type names to Lisp type names in the messages and services in 'schema'."
+ (map () #'resolve-lisp-names (proto-messages schema))
+ (map () #'resolve-lisp-names (proto-services schema)))
+
(defun parse-proto-syntax (stream schema &optional (terminator #\;))
"Parse a Protobufs syntax line from 'stream'.
Updates the 'protobuf-schema' object to use the syntax."
((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
(parse-number stream))
((eql ch #\{)
- ;;---bwagner: this is incorrect -- we need to find the field name in
- ;; the locally-extended version of
++ ;;---bwagner: This is incorrect
++ ;; We need to find the field name in the locally-extended version of
+ ;; google.protobuf.[File,Message,Field,Enum,EnumValue,Service,Method]Options
+ ;; and get its type
(let ((message (find-message (or protobuf *protobuf*) key)))
(if message
;; We've got a complex message as a value to an option
(name (prog1 (parse-token stream)
(expect-char stream #\{ () "extend")
(maybe-skip-comments stream)))
- ;;---bwagner: is 'extend' allowed to use a forward reference to a message?
++ ;;---bwagner: Is 'extend' allowed to use a forward reference to a message?
(message (find-message protobuf name))
(extends (and message
(make-instance 'protobuf-message
(setf (proto-fields message) (nconc (proto-fields message) (list field)))
field))))
- :type-name type
- :field field))
+ (defmethod resolve-lisp-names ((field protobuf-field))
+ "Resolves the field's protobuf type to a lisp type and sets `proto-class' for 'field'."
+ (let* ((type (proto-type field))
+ (ptype (when (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
+ "fixed32" "fixed64" "sfixed32" "sfixed64"
+ "string" "bytes" "bool" "float" "double") :test #'string=)
+ (kintern type)))
+ (message (unless ptype
+ (or (find-message (proto-parent field) type)
+ (find-enum (proto-parent field) type)))))
+ (unless (or ptype message)
+ (error 'undefined-field-type
++ :type-name type
++ :field field))
+ (setf (proto-class field) (or ptype (proto-class message))))
+ nil)
+
(defun parse-proto-group (stream message required &optional extended-from)
"Parse a (deprecated) Protobufs group from 'stream'.
Updates the 'protobuf-message' object to have the group type and field."
(setf (proto-methods service) (nconc (proto-methods service) (list method)))
method))
- (let* ((input-name (proto-input-name method))
- (output-name (proto-output-name method))
+ (defmethod resolve-lisp-names ((method protobuf-method))
+ "Resolves input, output, and streams protobuf type names to lisp type names and sets
+ `proto-input-type', `proto-output-type', and, if `proto-streams-name' is set,
+ `proto-streams-type' on 'method'."
- (schema (proto-parent service))
- (input-message (find-message schema input-name))
- (output-message (find-message schema output-name))
++ (let* ((input-name (proto-input-name method))
++ (output-name (proto-output-name method))
+ (streams-name (proto-streams-name method))
+ (service (proto-parent method))
- ;; this is supposed to be the fully-qualified name, but we don't
- ;; require that
++ (schema (proto-parent service))
++ (input-message (find-message schema input-name))
++ (output-message (find-message schema output-name))
+ (streams-message (and streams-name
- :type-name input-name
- :method method))
++ ;; This is supposed to be the fully-qualified name,
++ ;; but we don't require that
+ (find-message schema streams-name))))
+ (unless input-message
+ (error 'undefined-input-type
- :type-name output-name
- :method method))
++ :type-name input-name
++ :method method))
+ (unless output-message
+ (error 'undefined-output-type
- :type-name streams-name
- :method method))
++ :type-name output-name
++ :method method))
+ (setf (proto-input-type method) (proto-class input-message))
+ (setf (proto-output-type method) (proto-class output-message))
+ (when streams-name
+ (unless streams-message
+ (error 'undefined-stream-type
++ :type-name streams-name
++ :method method))
+ (setf (proto-streams-type method) (proto-class streams-message))))
+ nil)
+
(defun parse-proto-method-options (stream)
"Parse any options in a Protobufs method from 'stream'.
Returns a list of 'protobuf-option' objects."
(tag (make-tag type (proto-index field))))
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
- (setq index (serialize-prim v type tag buffer index))))))))
+ (setq index (serialize-prim v type tag buffer index))))))
+ (t
- (error 'undefined-field-type
- :format-control "While serializing ~s to protobuf,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field))))
++ (undefined-field-type "While serializing ~S,"
++ object type field))))
(t
(cond ((eq type :bool)
;; We have to handle optional boolean fields specially
(let* ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (setq index (serialize-prim v type tag buffer index)))))))))))))
+ (setq index (serialize-prim v type tag buffer index))))))
+ (t
- (error 'undefined-field-type
- :format-control "While serializing ~s to protobuf,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field)))))))))
++ (undefined-field-type "While serializing ~S,"
++ object type field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))))
(tag (make-tag type (proto-index field))))
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
- (iincf size (prim-size v type tag))))))))
+ (iincf size (prim-size v type tag))))))
+ (t
- (error 'undefined-field-type
- :format-control "While computing the size of ~s in bytes,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field))))
++ (undefined-field-type "While computing the size of ~S,"
++ object type field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(let* ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (iincf size (prim-size v type tag)))))))))))))
+ (iincf size (prim-size v type tag))))))
+ (t
- (error 'undefined-field-type
- :format-control "While computing the size of ~s in bytes,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field)))))))))
++ (undefined-field-type "While computing the size of ~S,"
++ object type field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))
(tag (make-tag class (proto-index field))))
`(,iterator (,vval ,reader)
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))))
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the serialize-object method ~
- for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field)))))
++ (undefined-field-type "While generating 'serialize-object' for ~S,"
++ message class field)))))
(t
(cond ((keywordp class)
(collect-serializer
`(let ((,vval ,reader))
(when ,vval
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))))))))
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the serialize-object method ~
- for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field))))))))
++ (undefined-field-type "While generating 'serialize-object' for ~S,"
++ message class field))))))))
`(defmethod serialize-object
(,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
(declare #.$optimize-serialization)
(multiple-value-bind (,vval idx)
(deserialize-prim ,class ,vbuf ,vidx)
(setq ,vidx idx)
- (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))))
+ (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the deserialize-object method ~
- for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field))))
++ (undefined-field-type "While generating 'deserialize-object' for ~S,"
++ message class field))))
(t
(cond ((keywordp class)
(collect-deserializer
(deserialize-prim ,class ,vbuf ,vidx)
(let ((,vval (funcall #',(proto-deserializer msg) ,vval)))
(setq ,vidx idx)
- ,(write-slot vobj field vval)))))))))))))
+ ,(write-slot vobj field vval)))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the deserialize-object method ~
- for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field))))))))
++ (undefined-field-type "While generating 'deserialize-object' for ~S,"
++ message class field))))))))
(let* ((rslots (delete-duplicates rslots :key #'first))
(rfields (mapcar #'first rslots))
(rtemps (mapcar #'second rslots)))
(tag (make-tag class index)))
`(,iterator (,vval ,reader)
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (iincf ,vsize (prim-size ,vval ,class ,tag))))))))))
+ (iincf ,vsize (prim-size ,vval ,class ,tag)))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the object-size method for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field)))))
++ (undefined-field-type "While generating 'object-size' for ~S,"
++ message class field)))))
(t
(cond ((keywordp class)
(let ((tag (make-tag class index)))
(tag (make-tag class index)))
`(let ((,vval ,reader))
(when ,vval
- (iincf ,vsize (prim-size
- (funcall #',(proto-serializer msg) ,vval)
- ,class ,tag)))))))
+ (iincf ,vsize (prim-size (funcall #',(proto-serializer msg) ,vval)
- ,class ,tag)))))))))))))
++ ,class ,tag)))))))
+ (t
- (error 'undefined-field-type
- :format-control "While generating the object-size method for ~s,"
- :format-arguments (list message)
- :type-name (prin1-to-string class)
- :field field))))))))
++ (undefined-field-type "While generating 'object-size' for ~S,"
++ message class field))))))))
`(defmethod object-size
(,vobj (,vclass (eql ,message)) &optional visited)
(declare #.$optimize-serialization)
"RUN-TEST"
"ASSERT-EQUAL"
"ASSERT-TRUE"
- "ASSERT-FALSE"))
+ "ASSERT-FALSE"
++ "ASSERT-ERROR")
++ (:export
++ "DEFINE-TEST"
++ "DEFINE-TEST-SUITE"
++ "REGISTER-TEST"
++ "RUN-TEST"
++ "RUN-ALL-TESTS"
++ "ASSERT-EQUAL"
++ "ASSERT-TRUE"
++ "ASSERT-FALSE"
+ "ASSERT-ERROR"))
+
++
++;;; Packages used by .oroto files
+
(defpackage protobuf-unittest
(:use :common-lisp :protobufs)
(:nicknames :pbtest))
(format t "~&Running test ~A" test)
(funcall test)))
- (defmacro assert-equal (actual expected &key (test 'eql))
+ (defmacro assert-equal (actual expected &key (test 'equal))
`(unless (,test ,actual ,expected)
-- (warn "The value ~S is not equal to the expected value ~S"
-- ',actual ',expected)))
++ (warn "The value of ~S (~S) is not equal to the expected value ~S"
++ ',actual ,actual ,expected)))
(defmacro assert-true (form)
`(unless ,form
-- (warn "The value ~S does not evaluate to 'true'"
-- ',form)))
++ (warn "The value of ~S (~S) does not evaluate to 'true'"
++ ',form ,form)))
(defmacro assert-false (form)
`(when ,form
-- (warn "The value ~S does not evaluate to 'false'"
-- ',form)))
++ (warn "The value ~S (~S) does not evaluate to 'false'"
++ ',form ,form)))
+
+ (defmacro assert-error (condition &body body)
+ "Checks if BODY signals a condition of class CONDITION. If it does not, a failure is
+ reported. If it is, the condition is caught and the condition object returned so that the test
+ can perform further checks on the condition object."
+ (let ((c (gensym "C")))
+ `(handler-case (progn ,@body)
+ (,condition (,c)
+ ,c)
+ (:no-error ()
+ (warn "Expected condition ~a while evaluating~{ ~s~}" ',condition ',body)))))
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
(print-prim v type field stream
- (or suppress-line-breaks indent))))))))
+ (or suppress-line-breaks indent))))))
+ (t
- (error 'undefined-field-type
- :format-control "While printing ~s to text format,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field))))
++ (undefined-field-type "While printing ~S to text format,"
++ object type field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(let ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg)))
(print-prim v type field stream
- (or suppress-line-breaks indent)))))))))))))
+ (or suppress-line-breaks indent))))))
+ (t
- (error 'undefined-field-type
- :format-control "While printing ~s to text format,"
- :format-arguments (list object)
- :type-name (prin1-to-string type)
- :field field)))))))))
++ (undefined-field-type "While printing ~S to text format,"
++ object type field)))))))))
(declare (dynamic-extent #'do-field))
(if print-name
(if suppress-line-breaks
(when slot
(pushnew slot rslots)
(push (funcall (proto-deserializer msg) val)
- (slot-value object slot))))))))
+ (slot-value object slot))))))
+ (t
- (error 'undefined-field-type
- :format-control "While parsing ~s from text format,"
- :format-arguments (list message)
- :type-name (prin1-to-string type)
- :field field))))
++ (undefined-field-type "While parsing ~S from text format,"
++ message type field))))
(t
(cond ((keywordp type)
(expect-char stream #\:)
(otherwise (parse-signed-int stream)))))
(when slot
(setf (slot-value object slot)
- (funcall (proto-deserializer msg) val)))))))))))))))
+ (funcall (proto-deserializer msg) val))))))
+ (t
- (error 'undefined-field-type
- :format-control "While parsing ~s from text format,"
- :format-arguments (list message)
- :type-name (prin1-to-string type)
- :field field)))))))))))
++ (undefined-field-type "While parsing ~S from text format,"
++ message type field)))))))))))
(declare (dynamic-extent #'deserialize))
(deserialize (proto-class message) message)))
projects / cl-protobufs.git / commitdiff