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

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 1d58fa307ba8b81f58b0c018e7aa718571dfa981..72af8b327138d908d86c6476e58f17f4bea0aa4f 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -708,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.
 
@@ -832,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.