Make the schema printer aware of qualified names.

Passes 'precheckin' with the new Protobufs unit tests in place.
CL-Stubby tests pass in Google3 environment.

git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/libs/cl-protobufs@551401 f8382938-511b-0410-9cdd-bb47b084005c

diff --git a/define-proto.lisp b/define-proto.lisp
index 2d8b8d07d9eb9464823e1da5552a03fb040f2eee..52215ad1b3a27772a21c6cd761aa3d7e7bb79154 100644 (file)
--- a/define-proto.lisp
+++ b/define-proto.lisp
@@ -296,18 +296,18 @@
          (alias-for (and message (proto-alias-for message)))
          (extends (and message
                        (make-instance 'protobuf-message
-                         :class  type
-                         :name   name
-                         :qualified-name (make-qualified-name *protobuf* name)
+                         :class  (proto-class message)
+                         :name   (proto-name message)
+                         :qualified-name (proto-qualified-name message)
                          :parent (proto-parent message)
                          :alias-for alias-for
                          :conc-name conc-name
                          :enums    (copy-list (proto-enums message))
                          :messages (copy-list (proto-messages message))
                          :fields   (copy-list (proto-fields message))
+                         :extensions (copy-list (proto-extensions message))
                          :options  (remove-options
                                      (or options (copy-list (proto-options message))) "default" "packed")
-                         :extensions (copy-list (proto-extensions message))
                          :message-type :extends         ;this message is an extension
                          :documentation documentation)))
          ;; Only now can we bind *protobuf* to the new extended message

diff --git a/model-classes.lisp b/model-classes.lisp
index fe12c84fe1278f984909c2764bf9945186b720f2..9d512586045be9aa9a5f017042031c65ee225e24 100644 (file)
--- a/model-classes.lisp
+++ b/model-classes.lisp
@@ -199,9 +199,11 @@
     generate a fully qualified name string for the name."))
 
 (defmethod make-qualified-name ((schema protobuf-schema) name)
-  ;; If we're at the parent, the qualified name is the schema's
-  ;; packaged "dot" the name
-  (strcat (proto-package schema) "." name))
+  ;; If we're at the schema, the qualified name is the schema's
+  ;; package "dot" the name
+  (if (proto-package schema)
+    (strcat (proto-package schema) "." name)
+    name))
 
 (defgeneric find-enum (protobuf type &optional relative-to)
   (:documentation
@@ -473,12 +475,14 @@
        (proto-lisp-package (proto-parent message))))
 
 (defmethod make-qualified-name ((message protobuf-message) name)
-  ;; If there's a parent for this message (there should be -- the schema),
-  ;; make a partially qualified name of message name "dot" name, then
-  ;; ask the parent to add its own qualifiers
-  (if (proto-parent message)
-    (make-qualified-name (proto-parent message) (strcat (proto-name message) "." name))
-    (strcat (proto-name message) "." name)))
+  ;; The qualified name is the message name "dot" the name
+  (let ((qual-name (strcat (proto-name message) "." name)))
+    (if (proto-parent message)
+      ;; If there's a parent for this message (either a message or
+      ;; the schema), prepend the name (or package) of the parent
+      (make-qualified-name (proto-parent message) qual-name)
+      ;; Guard against a message in the middle of nowhere
+      qual-name)))
 
 (defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
   ;; Extended messages "shadow" non-extended ones

diff --git a/parser.lisp b/parser.lisp
index 0b1a460e685484afd99b709cc1e13695611a28dc..109e695e4c8324a3bbe24c1692a4b3466b45f0f7 100644 (file)
--- a/parser.lisp
+++ b/parser.lisp
@@ -472,18 +472,20 @@
          (message (find-message protobuf name))
          (extends (and message
                        (make-instance 'protobuf-message
-                         :class (proto->class-name name *protobuf-package*)
-                         :name  name
-                         :qualified-name (make-qualified-name protobuf name)
+                         :class (proto-class message)
+                         :name  (proto-name message)
+                         :qualified-name (proto-qualified-name message)
                          :parent (proto-parent message)
-                         :conc-name (proto-conc-name message)
                          :alias-for (proto-alias-for message)
+                         :conc-name (proto-conc-name message)
                          :enums    (copy-list (proto-enums message))
                          :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
          (*protobuf* extends))
+    (assert message ()
+            "There is no message named ~A to extend" name)
     (loop
       (let ((token (parse-token stream)))
         (when (null token)

diff --git a/printer.lisp b/printer.lisp
index 1e7af7f6ddc75461dedb77bb2ca5940eb30c3ae0..9a8e6c913904841be1d7d6f88a05bbc3ea55bb61 100644 (file)
--- a/printer.lisp
+++ b/printer.lisp
@@ -42,7 +42,7 @@
 
 (defmethod write-schema-as ((type (eql :proto)) (schema protobuf-schema) stream
                             &key (indentation 0))
-  (with-prefixed-accessors (name documentation syntax package imports options) (proto- schema)
+  (with-prefixed-accessors (documentation syntax package imports options) (proto- schema)
     (when documentation
       (write-schema-documentation type documentation stream :indentation indentation))
     (when syntax
@@ -134,9 +134,15 @@
     (cond (colon-p                              ;~:/protobuf-option/ -- .proto format
            (let ((fmt-control
                   (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
-                         (if (eq type 'symbol) "(~A)~@[ = ~A~]" "(~A)~@[ = ~S~]"))
+                         (case type
+                           ((symbol) "(~A)~@[ = ~A~]")
+                           ((boolean) "(~A)~@[ = ~(~A~)~]")
+                           (otherwise "(~A)~@[ = ~S~]")))
                         (t
-                         (if (eq type 'symbol) "~A~@[ = ~A~]" "~A~@[ = ~S~]")))))
+                         (case type
+                           ((symbol) "~A~@[ = ~A~]")
+                           ((boolean) "~A~@[ = ~(~A~)~]")
+                           (otherwise "~A~@[ = ~S~]"))))))
              (format stream fmt-control (proto-name option) (proto-value option))))
           (atsign-p                             ;~@/protobuf-option/ -- .lisp format
            (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
@@ -180,63 +186,78 @@
 (defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
                             &key (indentation 0) more index arity)
   (declare (ignore more arity))
-  (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
-    (cond ((eq message-type :group)
-           ;; If we've got a group, the printer for fields has already
-           ;; printed a partial line (nice modularity, huh?)
-           (format stream "group ~A = ~D {~%" name index)
-           (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
-             (when other
-               (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
-                       (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
-           (when alias-for
-             (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
-                     (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
-           (dolist (option options)
-             (format stream "~&~VToption ~:/protobuf-option/;~%"
-                     (+ indentation 2) option))
-           (loop for (enum . more) on (proto-enums message) doing
-             (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
-           (loop for (field . more) on (proto-fields message) doing
-             (write-schema-as type field stream
-                              :indentation (+ indentation 2) :more more :message message))
-           (format stream "~&~@[~VT~]}~%"
-                   (and (not (zerop indentation)) indentation)))
-          (t
-           (when documentation
-             (write-schema-documentation type documentation stream :indentation indentation))
-           (format stream "~&~@[~VT~]~A ~A {~%"
-                   (and (not (zerop indentation)) indentation)
-                   (if (eq message-type :message) "message" "extend") name)
-           (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
-             (when other
-               (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
-                       (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
-           (when alias-for
-             (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
-                     (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
-           (dolist (option options)
-             (format stream "~&~VToption ~:/protobuf-option/;~%"
-                     (+ indentation 2) option))
-           (cond ((eq message-type :extends)
-                  (loop for (field . more) on (proto-extended-fields message) doing
-                    (write-schema-as type field stream
-                                     :indentation (+ indentation 2) :more more
-                                     :message message)))
-                 (t
-                  (loop for (enum . more) on (proto-enums message) doing
-                    (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
-                  (loop for (msg . more) on (proto-messages message) doing
-                    (unless (eq (proto-message-type msg) :group)
-                      (write-schema-as type msg stream :indentation (+ indentation 2) :more more)))
-                  (loop for (field . more) on (proto-fields message) doing
-                    (write-schema-as type field stream
-                                     :indentation (+ indentation 2) :more more
-                                     :message message))
-                  (loop for (extension . more) on (proto-extensions message) doing
-                    (write-schema-as type extension stream :indentation (+ indentation 2) :more more))))
-           (format stream "~&~@[~VT~]}~%"
-                   (and (not (zerop indentation)) indentation))))))
+  (let ((*protobuf* message))
+    (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
+      (cond ((eq message-type :group)
+             ;; If we've got a group, the printer for fields has already
+             ;; printed a partial line (nice modularity, huh?)
+             (format stream "group ~A = ~D {~%" name index)
+             (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
+               (when other
+                 (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
+                         (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
+             (when alias-for
+               (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
+                       (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
+             (dolist (option options)
+               (format stream "~&~VToption ~:/protobuf-option/;~%"
+                       (+ indentation 2) option))
+             (loop for (enum . more) on (proto-enums message) doing
+               (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
+             (loop for (field . more) on (proto-fields message) doing
+               (write-schema-as type field stream
+                                :indentation (+ indentation 2) :more more :message message))
+             (format stream "~&~@[~VT~]}~%"
+                     (and (not (zerop indentation)) indentation)))
+            (t
+             (when documentation
+               (write-schema-documentation type documentation stream :indentation indentation))
+             (format stream "~&~@[~VT~]~A ~A {~%"
+                     (and (not (zerop indentation)) indentation)
+                     (if (eq message-type :message) "message" "extend") 
+                     (maybe-qualified-name message))
+             (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
+               (when other
+                 (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
+                         (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
+             (when alias-for
+               (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
+                       (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
+             (dolist (option options)
+               (format stream "~&~VToption ~:/protobuf-option/;~%"
+                       (+ indentation 2) option))
+             (cond ((eq message-type :extends)
+                    (loop for (field . more) on (proto-extended-fields message) doing
+                      (write-schema-as type field stream
+                                       :indentation (+ indentation 2) :more more
+                                       :message message)))
+                   (t
+                    (loop for (enum . more) on (proto-enums message) doing
+                      (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
+                    (loop for (msg . more) on (proto-messages message) doing
+                      (unless (eq (proto-message-type msg) :group)
+                        (write-schema-as type msg stream :indentation (+ indentation 2) :more more)))
+                    (loop for (field . more) on (proto-fields message) doing
+                      (write-schema-as type field stream
+                                       :indentation (+ indentation 2) :more more
+                                       :message message))
+                    (loop for (extension . more) on (proto-extensions message) doing
+                      (write-schema-as type extension stream :indentation (+ indentation 2) :more more))))
+             (format stream "~&~@[~VT~]}~%"
+                     (and (not (zerop indentation)) indentation)))))))
+
+(defun maybe-qualified-name (message &optional name)
+  "Given a message, return a fully qualified name if the short name
+   is not sufficient to name the message in the current scope."
+  (etypecase message
+    (protobuf-message
+     (cond ((string= (make-qualified-name (proto-parent message) (proto-name message))
+                     (proto-qualified-name message))
+            (proto-name message))
+           (t
+            (proto-qualified-name message))))
+    ((or null protobuf-enum)
+     name)))
 
 (defparameter *protobuf-field-comment-column* 56)
 (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream
@@ -282,7 +303,8 @@
                                  ~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
                                  ~:[~*~*~;~VT// ~A~]~%")
                        (and (not (zerop indentation)) indentation)
-                       required type name index defaultp default packed options
+                       required (maybe-qualified-name msg type) name index
+                       defaultp default packed options
                        documentation *protobuf-field-comment-column* documentation)))))))
 
 (defun escape-string (string)
@@ -318,21 +340,26 @@
 (defmethod write-schema-as ((type (eql :proto)) (method protobuf-method) stream
                             &key (indentation 0) more)
   (declare (ignore more))
-  (with-prefixed-accessors (name documentation input-name output-name options) (proto- method)
-    (when documentation
-      (write-schema-documentation type documentation stream :indentation indentation))
-    (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
-            (and (not (zerop indentation)) indentation)
-            name input-name output-name)
-    (cond (options
-           (format stream " {~%")
-           (dolist (option options)
-             (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
-                     (+ indentation 2) option))
-           (format stream "~@[~VT~]}"
-                   (and (not (zerop indentation)) indentation)))
-          (t
-           (format stream ";~%")))))
+  (with-prefixed-accessors
+      (name documentation input-name output-name options) (proto- method)
+    (let* ((imsg (find-message *protobuf* input-name))
+           (omsg (find-message *protobuf* output-name))
+           (iname (maybe-qualified-name imsg))
+           (oname (maybe-qualified-name omsg)))
+      (when documentation
+        (write-schema-documentation type documentation stream :indentation indentation))
+      (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
+              (and (not (zerop indentation)) indentation)
+              name iname oname)
+      (cond (options
+             (format stream " {~%")
+             (dolist (option options)
+               (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
+                       (+ indentation 2) option))
+             (format stream "~@[~VT~]}"
+                     (and (not (zerop indentation)) indentation)))
+            (t
+             (format stream ";~%"))))))
 
 
 ;;; Pretty print a schema as a .lisp file
@@ -462,85 +489,86 @@
 (defmethod write-schema-as ((type (eql :lisp)) (message protobuf-message) stream
                             &key (indentation 0) more index arity)
   (declare (ignore more))
-  (with-prefixed-accessors (name class alias-for conc-name message-type documentation) (proto- message)
-    (cond ((eq message-type :group)
-           (when documentation
-             (write-schema-documentation type documentation stream :indentation indentation))
-           (format stream "~&~@[~VT~](proto:define-group ~(~S~)"
-                   (and (not (zerop indentation)) indentation) class)
-           (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
-             (format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
-                                        :arity ~(~S~)~@[~%~VT~]~
-                                        ~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
-                                        ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
-                                        ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
-                                        ~:[~*~;:documentation ~S~])"
-                     (+ indentation 4)
-                     index (+ indentation 5)
-                     arity (and (or other alias-for conc-name documentation) (+ indentation 5))
-                     other other (and (or alias-for conc-name documentation) (+ indentation 5))
-                     alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
-                     conc-name conc-name (and documentation (+ indentation 5))
-                     documentation documentation))
-           (loop for (enum . more) on (proto-enums message) doing
-             (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
-             (when more
-               (terpri stream)))
-           (loop for (field . more) on (proto-fields message) doing
-             (write-schema-as type field stream
-                              :indentation (+ indentation 2) :more more
-                              :message message)
-             (when more
-               (terpri stream))))
-          (t
-           (when documentation
-             (write-schema-documentation type documentation stream :indentation indentation))
-           (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
-                   (and (not (zerop indentation)) indentation)
-                   (if (eq message-type :message) "message" "extend") class)
-           (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+  (let ((*protobuf* message))
+    (with-prefixed-accessors (name class alias-for conc-name message-type documentation) (proto- message)
+      (cond ((eq message-type :group)
+             (when documentation
+               (write-schema-documentation type documentation stream :indentation indentation))
+             (format stream "~&~@[~VT~](proto:define-group ~(~S~)"
+                     (and (not (zerop indentation)) indentation) class)
+             (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+               (format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
+                                          :arity ~(~S~)~@[~%~VT~]~
+                                          ~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
+                                          ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+                                          ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+                                          ~:[~*~;:documentation ~S~])"
+                       (+ indentation 4)
+                       index (+ indentation 5)
+                       arity (and (or other alias-for conc-name documentation) (+ indentation 5))
+                       other other (and (or alias-for conc-name documentation) (+ indentation 5))
+                       alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
+                       conc-name conc-name (and documentation (+ indentation 5))
+                       documentation documentation))
+             (loop for (enum . more) on (proto-enums message) doing
+               (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
+               (when more
+                 (terpri stream)))
+             (loop for (field . more) on (proto-fields message) doing
+               (write-schema-as type field stream
+                                :indentation (+ indentation 2) :more more
+                                :message message)
+               (when more
+                 (terpri stream))))
+            (t
+             (when documentation
+               (write-schema-documentation type documentation stream :indentation indentation))
+             (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
+                     (and (not (zerop indentation)) indentation)
+                     (if (eq message-type :message) "message" "extend") class)
+             (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+               (cond ((eq message-type :extends)
+                      (format stream " ()"))
+                     ((or other alias-for conc-name documentation)
+                      (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
+                                                 ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+                                                 ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+                                                 ~:[~*~;:documentation ~S~])"
+                              (+ indentation 4)
+                              other other (and (or alias-for conc-name documentation) (+ indentation 5))
+                              alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
+                              conc-name conc-name (and documentation (+ indentation 5))
+                              documentation documentation))
+                     (t
+                      (format stream " ()"))))
              (cond ((eq message-type :extends)
-                    (format stream " ()"))
-                   ((or other alias-for conc-name documentation)
-                    (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
-                                               ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
-                                               ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
-                                               ~:[~*~;:documentation ~S~])"
-                            (+ indentation 4)
-                            other other (and (or alias-for conc-name documentation) (+ indentation 5))
-                            alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
-                            conc-name conc-name (and documentation (+ indentation 5))
-                            documentation documentation))
-                   (t
-                    (format stream " ()"))))
-           (cond ((eq message-type :extends)
-                  (loop for (field . more) on (proto-extended-fields message) doing
-                    (write-schema-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-schema-as type enum stream :indentation (+ indentation 2) :more more)
-                    (when more
-                      (terpri stream)))
-                  (loop for (msg . more) on (proto-messages message) doing
-                    (unless (eq (proto-message-type msg) :group)
-                      (write-schema-as type msg stream :indentation (+ indentation 2) :more more)
+                    (loop for (field . more) on (proto-extended-fields message) doing
+                      (write-schema-as type field stream
+                                       :indentation (+ indentation 2) :more more
+                                       :message message)
                       (when more
                         (terpri stream))))
-                  (loop for (field . more) on (proto-fields message) doing
-                    (write-schema-as type field stream
-                                     :indentation (+ indentation 2) :more more
-                                     :message message)
-                    (when more
-                      (terpri stream)))
-                  (loop for (extension . more) on (proto-extensions message) doing
-                    (write-schema-as type extension stream :indentation (+ indentation 2) :more more)
-                    (when more
-                      (terpri stream)))))))
-    (format stream ")")))
+                   (t
+                    (loop for (enum . more) on (proto-enums message) doing
+                      (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
+                      (when more
+                        (terpri stream)))
+                    (loop for (msg . more) on (proto-messages message) doing
+                      (unless (eq (proto-message-type msg) :group)
+                        (write-schema-as type msg stream :indentation (+ indentation 2) :more more)
+                        (when more
+                          (terpri stream))))
+                    (loop for (field . more) on (proto-fields message) doing
+                      (write-schema-as type field stream
+                                       :indentation (+ indentation 2) :more more
+                                       :message message)
+                      (when more
+                        (terpri stream)))
+                    (loop for (extension . more) on (proto-extensions message) doing
+                      (write-schema-as type extension stream :indentation (+ indentation 2) :more more)
+                      (when more
+                        (terpri stream)))))))
+      (format stream ")"))))
 
 (defparameter *protobuf-slot-comment-column* 56)
 (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream

diff --git a/tests/qtest.lisp b/tests/qtest.lisp
new file mode 100644 (file)
index 0000000..2c0156b
--- /dev/null
+++ b/tests/qtest.lisp
@@ -0,0 +1,62 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;                                                                  ;;;
+;;; Free Software published under an MIT-like license. See LICENSE   ;;;
+;;;                                                                  ;;;
+;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
+;;;                                                                  ;;;
+;;; Original author: Scott McKay                                     ;;;
+;;;                                                                  ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package "PROTO-TEST")
+
+
+;;; Ultra light-weight test framework
+
+(defmacro define-test (test-name () &body body)
+  `(defun ,test-name ()
+     (handler-case
+         (progn ,@body)
+       (error (e)
+         (warn "An error was signalled executing ~S: ~A"
+               ',test-name e)))))
+
+(defmacro define-test-suite (suite-name () &body body)
+  (if (listp (car body))
+    ;; QRes-style body
+    `(defun ,suite-name ()
+       ,@(loop for test in (car body)
+               collect (list test)))
+    ;; The more sensible style
+    `(defun ,suite-name ()
+       ,@(loop for test in body
+               collect (list test)))))
+
+(defvar *all-registered-tests* ())
+(defmacro register-test (test-name)
+  `(pushnew ',test-name *all-registered-tests*))
+
+(defmacro run-test (test-name)
+  `(progn
+     (format t "~&Running test ~A" ',test-name)
+     (funcall ',test-name)))
+
+(defun run-all-tests ()
+  (dolist (test *all-registered-tests*)
+    (format t "~&Running test ~A" test)
+    (funcall test)))
+
+(defmacro assert-equal (actual expected &key (test 'eql))
+  `(unless (,test ,actual ,expected)
+     (warn "The value ~S is not equal to the expected value ~S"
+           ',actual ',expected)))
+
+(defmacro assert-true (form)
+  `(unless ,form
+     (warn "The value ~S does not evaluate to 'true'"
+           ',form)))
+
+(defmacro assert-false (form)
+  `(when ,form
+     (warn "The value ~S does not evaluate to 'false'"
+           ',form)))