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 ;; We don't specify a :report for simple-reader-error to let the
  16 ;; underlying implementation report the line and column position for
  17 ;; us. Unfortunately this way the message from simple-error is not
  18 ;; displayed, unless there's special support for that in the
  19 ;; implementation. But even then it's still inspectable from the
  20 ;; debugger...
  21 (define-condition simple-reader-error
  22     #-sbcl(reader-error simple-error)
  23     #+sbcl(sb-int:simple-reader-error)
  24   ())
  25
  26 (defun simple-reader-error (stream message &rest args)
  27   (error 'simple-reader-error
  28          :stream stream
  29          :format-control message
  30          :format-arguments args))
  31
  32 (define-condition simple-parse-error (simple-error parse-error)
  33   ())
  34
  35 (defun simple-parse-error (message &rest args)
  36   (error 'simple-parse-error
  37          :format-control message
  38          :format-arguments args))
  39
  40 (define-condition simple-program-error (simple-error program-error)
  41   ())
  42
  43 (defun simple-program-error (message &rest args)
  44   (error 'simple-program-error
  45          :format-control message
  46          :format-arguments args))
  47
  48 (defmacro ignore-some-conditions ((&rest conditions) &body body)
  49   "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
  50 list determines which specific conditions are to be ignored."
  51   `(handler-case
  52        (progn ,@body)
  53      ,@(loop for condition in conditions collect
  54              `(,condition (c) (values nil c)))))
  55
  56 (defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
  57   "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
  58 the cleanup CLAUSES are run.
  59
  60   clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
  61
  62 Clauses can be given in any order, and more than one clause can be
  63 given for each circumstance. The clauses whose denoted circumstance
  64 occured, are executed in the order the clauses appear.
  65
  66 ABORT-FLAG is the name of a variable that will be bound to T in
  67 CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
  68 otherwise.
  69
  70 Examples:
  71
  72   (unwind-protect-case ()
  73        (protected-form)
  74      (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
  75      (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
  76      (:always (format t \"This is evaluated in either case.~%\")))
  77
  78   (unwind-protect-case (aborted-p)
  79        (protected-form)
  80      (:always (perform-cleanup-if aborted-p)))
  81 "
  82   (check-type abort-flag (or null symbol))
  83   (let ((gflag (gensym "FLAG+")))
  84     `(let ((,gflag t))
  85        (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
  86          (let ,(and abort-flag `((,abort-flag ,gflag)))
  87            ,@(loop for (cleanup-kind . forms) in clauses
  88                    collect (ecase cleanup-kind
  89                              (:normal `(when (not ,gflag) ,@forms))
  90                              (:abort  `(when ,gflag ,@forms))
  91                              (:always `(progn ,@forms)))))))))