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

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 1c3c930..f65ed73 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -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.
@@ -148,12 +194,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 +208,14 @@
 			:location (file-location floc)
 			initargs)
 		 (wrap (apply #'make-condition type initargs)))))
-    (etypecase datum
-      (condition-with-location datum)
-      (condition (wrap datum))
-      (symbol (apply #'make arguments))
+    (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 +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.
 
@@ -294,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)))