X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/89ef4001b93c0219096c94125e7e9fdb745d2c97..e43bd9558b80d9d92db3f39b5f77a2fa184fb467:/src/parser/floc-proto.lisp?ds=sidebyside

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 484fce0..3a11123 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,46 @@
     (warning-with-location simple-warning)
   ())
 
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+  ())
+
+(export 'info)
+(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 'noted)
+(defun noted (&optional condition)
+  "Invoke the `noted' restart, possibly associated with the given CONDITION."
+  (invoke-associated-restart 'noted condition))
+
+(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.
@@ -148,12 +199,12 @@
    if the condition was a subtype of ERROR or WARNING then the resulting
    condition will also be subtype of ERROR or WARNING as appropriate."
 
-  (labels ((wrap (condition)
+  (labels ((check-no-args ()
+	     (unless (null arguments)
+	       (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)
@@ -162,13 +213,14 @@
 			:location (file-location floc)
 			initargs)
 		 (wrap (apply #'make-condition type initargs)))))
-    (etypecase datum
-      (condition-with-location datum)
-      (condition (wrap datum))
+    (typecase datum
+      (condition-with-location (check-no-args) datum)
+      (condition (check-no-args) (wrap datum))
       (symbol (apply #'make datum arguments))
       ((or string function) (make default-type
 				  :format-control datum
-				  :format-arguments arguments)))))
+				  :format-arguments arguments))
+      (t (error "Unexpected condition designator datum ~S" datum)))))
 
 (export 'error-with-location)
 (defun error-with-location (floc datum &rest arguments)
@@ -184,6 +236,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.
 
@@ -288,13 +347,18 @@
 			  (if fatal
 			      (return-from count-and-report-errors*
 				(values nil errors warnings))
-			      (invoke-restart 'continue)))))
+			      (continue error)))))
 	       (warning (lambda (warning)
 			  (format *error-output* "~&~A: Warning: ~A~%"
 				  (file-location warning)
 				  warning)
 			  (incf warnings)
-			  (invoke-restart 'muffle-warning))))
+			  (muffle-warning warning)))
+	       (information (lambda (info)
+			      (format *error-output* "~&~A: Info: ~A~%"
+				      (file-location info)
+				      info)
+			      (noted info))))
 	    (values (funcall thunk)
 		    errors
 		    warnings)))