X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ad1316527a6aa066d0abc0ada46a3616f5cb451f..6e92afa75860a55640efa6f3ba39f9624b41e8a8:/src/parser/floc-proto.lisp

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index c681b24..f65ed73 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -83,6 +83,10 @@
     (condition-with-location enclosing-condition)
   ())
 
+(export 'information)
+(define-condition information (condition)
+  ())
+
 (export 'error-with-location)
 (define-condition error-with-location (condition-with-location error)
   ())
@@ -91,6 +95,11 @@
 (define-condition warning-with-location (condition-with-location warning)
   ())
 
+(export 'information-with-location)
+(define-condition information-with-location
+    (condition-with-location information)
+  ())
+
 (export 'enclosing-error-with-location)
 (define-condition enclosing-error-with-location
     (enclosing-condition-with-location error)
@@ -101,6 +110,11 @@
     (enclosing-condition-with-location warning)
   ())
 
+(export 'enclosing-information-with-location)
+(define-condition enclosing-information-with-location
+    (enclosing-condition-with-location information)
+  ())
+
 (export 'simple-condition-with-location)
 (define-condition simple-condition-with-location
     (condition-with-location simple-condition)
@@ -116,9 +130,41 @@
     (warning-with-location simple-warning)
   ())
 
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+  ())
+
+(export '(info noted))
+(defun info (datum &rest arguments)
+  "Report some useful diagnostic information.
+
+   Establish a simple restart named `noted', and signal the condition of type
+   `information' designated by DATUM and ARGUMENTS.  Return non-nil if the
+   restart was invoked, otherwise nil."
+  (restart-case
+      (signal (designated-condition 'simple-information datum arguments))
+    (noted () :report "Noted." t)))
+
+(export 'simple-information-with-location)
+(define-condition simple-information-with-location
+    (information-with-location simple-information)
+  ())
+
 ;;;--------------------------------------------------------------------------
 ;;; Reporting errors.
 
+(export 'enclosing-condition-with-location-type)
+(defgeneric enclosing-condition-with-location-type (condition)
+  (:documentation
+   "Return a class suitable for attaching location information to CONDITION.
+
+    Specifically, return the name of a subclass of `enclosing-condition-
+    with-location' suitable to enclose CONDITION.")
+  (:method ((condition error)) 'enclosing-error-with-location)
+  (:method ((condition warning)) 'enclosing-warning-with-location)
+  (:method ((condition information)) 'enclosing-information-with-location)
+  (:method ((condition condition)) 'enclosing-condition-with-location))
+
 (export 'make-condition-with-location)
 (defun make-condition-with-location (default-type floc datum &rest arguments)
   "Construct a `condition-with-location' given a condition designator.
@@ -153,10 +199,7 @@
 	       (error "Argument list provided with specific condition")))
 	   (wrap (condition)
 	     (make-condition
-	      (etypecase condition
-		(error 'enclosing-error-with-location)
-		(warning 'enclosing-warning-with-location)
-		(condition 'enclosing-condition-with-location))
+	      (enclosing-condition-with-location-type condition)
 	      :condition condition
 	      :location (file-location floc)))
 	   (make (type &rest initargs)
@@ -188,6 +231,13 @@
 	       'simple-warning-with-location
 	       floc datum arguments)))
 
+(export 'info-with-location)
+(defun info-with-location (floc datum &rest arguments)
+  "Report some information with attached location information."
+  (info (apply #'make-condition-with-location
+	       'simple-information-with-location
+	       floc datum arguments)))
+
 (defun my-cerror (continue-string datum &rest arguments)
   "Like standard `cerror', but robust against sneaky changes of conditions.
 
@@ -298,7 +348,12 @@
 				  (file-location warning)
 				  warning)
 			  (incf warnings)
-			  (invoke-restart 'muffle-warning))))
+			  (invoke-restart 'muffle-warning)))
+	       (information (lambda (info)
+			      (format *error-output* "~&~A: Info: ~A~%"
+				      (file-location info)
+				      info)
+			  (invoke-restart 'noted))))
 	    (values (funcall thunk)
 		    errors
 		    warnings)))