Abandoned atoms work: hardly any performance benefit.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index b02fdf4..bdcdf80 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -526,17 +526,21 @@
                         (cdddr neigh-record) best-path)))))))
     dead))
 
-(export '(inconsistent-merge-error merge-error-candidates))
+(export '(inconsistent-merge-error
+         merge-error-candidates merge-error-present-function))
 (define-condition inconsistent-merge-error (error)
   ((candidates :initarg :candidates
-              :reader merge-error-candidates))
+              :reader merge-error-candidates)
+   (present :initarg :present :initform #'identity
+           :reader merge-error-present-function))
   (:documentation
    "Reports an inconsistency in the arguments passed to `merge-lists'.")
   (:report (lambda (condition stream)
             (format stream "Merge inconsistency: failed to decide between ~
                             ~{~#[~;~A~;~A and ~A~:;~
                                  ~@{~A, ~#[~;and ~A~]~}~]~}"
-                    (merge-error-candidates condition)))))
+                    (mapcar (merge-error-present-function condition)
+                            (merge-error-candidates condition))))))
 
 (export 'merge-lists)
 (defun merge-lists (lists &key pick (test #'eql) (present #'identity))
@@ -593,7 +597,8 @@
                              candidates))
           (winner (cond ((null leasts)
                          (error 'inconsistent-merge-error
-                                :candidates (mapcar present candidates)))
+                                :candidates candidates
+                                :present present))
                         ((null (cdr leasts))
                          (car leasts))
                         (pick
@@ -646,16 +651,17 @@
                                                   (symbol-name name) "-")))
                           cat-names))
         (items-var (gensym "ITEMS-")))
-    `(let ((,items-var ,items)
-          ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
-       (dolist (,itemvar ,items-var)
-        (let* ,bind
-          (cond ,@(mapcar (lambda (cat-match-form cat-var)
-                            `(,cat-match-form
-                              (push ,itemvar ,cat-var)))
-                          cat-match-forms cat-vars)
-                ,@(and (not (member t cat-match-forms))
-                       `((t (error "Failed to categorize ~A" ,itemvar)))))))
+    `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+       (let ((,items-var ,items))
+        (dolist (,itemvar ,items-var)
+          (let* ,bind
+            (cond ,@(mapcar (lambda (cat-match-form cat-var)
+                              `(,cat-match-form
+                                (push ,itemvar ,cat-var)))
+                            cat-match-forms cat-vars)
+                  ,@(and (not (member t cat-match-forms))
+                         `((t (error "Failed to categorize ~A"
+                                     ,itemvar))))))))
        (let ,(mapcar (lambda (name var)
                       `(,name (nreverse ,var)))
                     cat-names cat-vars)
@@ -1033,6 +1039,61 @@
                                            condition)))
         arguments))
 
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+  ((%enclosed-condition :initarg :condition :type condition
+                       :reader enclosed-condition))
+  (:documentation
+   "A condition which encloses another condition
+
+   This is useful if one wants to attach additional information to an
+   existing condition.  The enclosed condition can be obtained using the
+   `enclosed-condition' function.")
+  (:report (lambda (condition stream)
+            (princ (enclosed-condition condition) stream))))
+
+(export 'information)
+(define-condition information (condition)
+  ())
+
+(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 'promiscuous-cerror)
+(defun promiscuous-cerror (continue-string datum &rest arguments)
+  "Like standard `cerror', but robust against sneaky changes of conditions.
+
+   It seems that `cerror' (well, at least the version in SBCL) is careful
+   to limit its restart to the specific condition it signalled.  But that's
+   annoying, because `sod-parser:with-default-error-location' substitutes
+   different conditions carrying the error-location information."
+  (restart-case (apply #'error datum arguments)
+    (continue ()
+      :report (lambda (stream)
+               (apply #'format stream continue-string datum arguments))
+      nil)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+  (apply #'promiscuous-cerror "Continue" datum arguments))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.