conditions.lisp

   1 (in-package :alexandria)
   2
   3 (defun required-argument (&optional name)
   4   "Signals an error for a missing argument of NAME. Intended for
   5 use as an initialization form for structure and class-slots, and
   6 a default value for required keyword arguments."
   7   (error "Required argument ~@[~S ~]missing." name))
   8
   9 (define-condition simple-style-warning (style-warning simple-warning)
  10   ())
  11
  12 (defun simple-style-warning (message &rest args)
  13   (warn 'simple-style-warning :format-control message :format-arguments args))
  14
  15 (define-condition simple-reader-error (reader-error simple-error)
  16   ())
  17
  18 (defun simple-reader-error (message &rest args)
  19   (warn 'simple-reader-error :format-control message :format-arguments args))
  20
  21 (defmacro ignore-some-conditions ((&rest conditions) &body body)
  22   "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
  23 list determines which specific conditions are to be ignored."
  24   `(handler-case
  25        (progn ,@body)
  26      ,@(loop for condition in conditions collect
  27              `(,condition (c) (values nil c)))))
  28
  29 (defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
  30   "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
  31 the cleanup CLAUSES are run.
  32
  33 ABORT-FLAG is the name of a variable that will be bound to T in
  34 CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
  35 otherwise.
  36
  37 Examples:
  38
  39   (unwind-protect-case ()
  40        (protected-form)
  41      (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
  42      (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
  43      (:always (format t \"This is evaluated in either case.~%\")))
  44
  45   (unwind-protect-case (aborted-p)
  46        (protected-form)
  47      (:always (perform-cleanup-if aborted-p)))
  48 "
  49   (check-type abort-flag (or null symbol))
  50   (let ((gflag (gensym "FLAG+")))
  51     `(let ((,gflag t))
  52        (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
  53          (let ,(and abort-flag `((,abort-flag ,gflag)))
  54            ,@(loop for (cleanup-kind . forms) in clauses
  55                    collect (ecase cleanup-kind
  56                              (:normal `(when (not ,gflag) ,@forms))
  57                              (:abort  `(when ,gflag ,@forms))
  58                              (:always `(progn ,@forms)))))))))