src/lexer-proto.lisp: New parser `must'.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 6663441df78e75579308a04c95360d123ff5843b..72af8b327138d908d86c6476e58f17f4bea0aa4f 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -273,6 +273,22 @@ (defmacro awhen (cond &body body)
   "If COND, evaluate BODY as a progn with `it' bound to the value of COND."
   `(let ((it ,cond)) (when it ,@body)))
 
+(export 'aand)
+(defmacro aand (&rest forms)
+  "Like `and', but anaphoric.
+
+   Each FORM except the first is evaluated with `it' bound to the value of
+   the previous one.  If there are no forms, then the result it `t'; if there
+   is exactly one, then wrapping it in `aand' is pointless."
+  (labels ((doit (first rest)
+            (if (null rest)
+                first
+                `(let ((it ,first))
+                   (if it ,(doit (car rest) (cdr rest)) nil)))))
+    (if (null forms)
+       't
+       (doit (car forms) (cdr forms)))))
+
 (export 'acond)
 (defmacro acond (&body clauses &environment env)
   "Like COND, but with `it' bound to the value of the condition.
@@ -430,11 +446,13 @@ (define-condition inconsistent-merge-error (error)
   (:documentation
    "Reports an inconsistency in the arguments passed to `merge-lists'.")
   (:report (lambda (condition stream)
-            (format stream "Merge inconsistency: failed to decide among ~A."
+            (format stream "Merge inconsistency: failed to decide between ~
+                            ~{~#[~;~A~;~A and ~A~:;~
+                                 ~@{~A, ~#[~;and ~A~]~}~]~}"
                     (merge-error-candidates condition)))))
 
 (export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
   "Return a merge of the given LISTS.
 
    The resulting list contains the items of the given LISTS, with duplicates
@@ -442,7 +460,10 @@ (defun merge-lists (lists &key pick (test #'eql))
    the input LISTS in the sense that if A precedes B in some input list then
    A will also precede B in the output list.  If the lists aren't consistent
    (e.g., some list contains A followed by B, and another contains B followed
-   by A) then an error of type `inconsistent-merge-error' is signalled.
+   by A) then an error of type `inconsistent-merge-error' is signalled.  The
+   offending items are filtered for presentation through the PRESENT function
+   before being attached to the condition, so as to produce a more useful
+   diagnostic message.
 
    Item equality is determined by TEST.
 
@@ -484,7 +505,7 @@ (defun merge-lists (lists &key pick (test #'eql))
                              candidates))
           (winner (cond ((null leasts)
                          (error 'inconsistent-merge-error
-                                :candidates candidates))
+                                :candidates (mapcar present candidates)))
                         ((null (cdr leasts))
                          (car leasts))
                         (pick
@@ -687,6 +708,17 @@ (defun compose (function &rest more-functions)
               (multiple-value-call func-b (apply func-a args)))))
     (reduce #'compose1 more-functions :initial-value function)))
 
+;;;--------------------------------------------------------------------------
+;;; Variables.
+
+(export 'defvar-unbound)
+(defmacro defvar-unbound (var doc)
+  "Make VAR a special variable with documentation DOC, but leave it unbound."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defvar ,var)
+     (setf (documentation ',var 'variable) ',doc)
+     ',var))
+
 ;;;--------------------------------------------------------------------------
 ;;; Symbols.
 
@@ -811,6 +843,30 @@      (defun ,from (object)
            `((defun (setf ,from) (value object)
                (setf (,to object) value))))))
 
+;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+                            &key allow-pointless-arguments)
+  "Return the condition designated by DATUM and ARGUMENTS.
+
+   DATUM and ARGUMENTS together are a `condition designator' of (some
+   supertype of) DEFAULT-TYPE; return the condition so designated."
+  (typecase datum
+    (condition
+     (unless (or allow-pointless-arguments (null arguments))
+       (error "Argument list provided with specific condition"))
+     datum)
+    (symbol
+     (apply #'make-condition datum arguments))
+    ((or string function)
+     (make-condition default-type
+                    :format-control datum
+                    :format-arguments arguments))
+    (t
+     (error "Unexpected condition designator datum ~S" datum))))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.