compute-restarts.lsp 3.59 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Mar 22 23:48:53 2003
;;;; Contains: Tests of COMPUTE-RESTARTS

(in-package :cl-test)

(deftest compute-restarts.1
  (loop for r in (compute-restarts)
sds's avatar
sds committed
10
        always (typep r 'restart))
pfdietz's avatar
pfdietz committed
11 12 13 14
  t)

(deftest compute-restarts.2
  (loop for r in (compute-restarts)
sds's avatar
sds committed
15
        always (typep r (find-class 'restart)))
pfdietz's avatar
pfdietz committed
16 17 18 19 20 21 22 23 24 25 26
  t)

(deftest compute-restarts.3
  (restart-case
   (let ((r (find-restart 'foo)))
     (eqt r (find 'foo (compute-restarts) :key #'restart-name)))
   (foo () nil))
  t)

(deftest compute-restarts.4
  (loop for r1 in (compute-restarts)
sds's avatar
sds committed
27 28
        for r2 in (compute-restarts)
        always (eq r1 r2))
pfdietz's avatar
pfdietz committed
29 30 31 32 33
  t)

(deftest compute-restarts.5
  (restart-case
   (loop for r1 in (compute-restarts)
sds's avatar
sds committed
34 35
         for r2 in (compute-restarts)
         always (eq r1 r2))
pfdietz's avatar
pfdietz committed
36 37 38 39 40 41 42 43
   (foo () t)
   (bar () t)
   (foo () nil))
  t)

(deftest compute-restarts.6
  (restart-case
   (let* ((restarts (compute-restarts))
sds's avatar
sds committed
44 45
          (p (position 'foo restarts :key #'restart-name))
          (r (find 'foo restarts :start (1+ p) :key #'restart-name)))
pfdietz's avatar
pfdietz committed
46 47 48 49 50 51 52 53 54
     (invoke-restart r))
   (foo () 'bad)
   (foo () 'good)
   (foo () 'bad))
  good)

(deftest compute-restarts.7
  (handler-bind
   ((error #'(lambda (c)
sds's avatar
sds committed
55 56 57 58 59
               (let* ((restarts (compute-restarts c))
                      (r (remove 'foo restarts
                                 :test-not #'eq
                                 :key #'restart-name)))
                 (invoke-restart (second r))))))
pfdietz's avatar
pfdietz committed
60 61 62 63 64 65 66 67 68 69
   (restart-case
    (error "an error")
    (foo () 'bad)
    (foo () 'good)
    (foo () 'bad)))
  good)

(deftest compute-restarts.8
  (handler-bind
   ((error #'(lambda (c)
sds's avatar
sds committed
70 71 72 73 74 75
               (declare (ignore c))
               (let* ((restarts (compute-restarts))
                      (r (remove 'foo restarts
                                 :test-not #'eq
                                 :key #'restart-name)))
                 (invoke-restart (second r))))))
pfdietz's avatar
pfdietz committed
76 77 78 79 80 81 82 83 84 85 86 87
   (restart-case
    (error "an error")
    (foo () 'bad)
    (foo () 'good)
    (foo () 'bad)))
  good)

(deftest compute-restarts.9
  (let ((c2 (make-condition 'error)))
    (block done
      (handler-bind
       ((error #'(lambda (c)
sds's avatar
sds committed
88 89 90 91 92 93 94 95 96
                   (declare (ignore c))
                   (let* ((restarts (compute-restarts c2))
                          (r (remove 'foo restarts
                                     :test-not #'eq
                                     :key #'restart-name)))
                     ;; (write restarts)
                     (return-from done
                       (values r
                               (mapcar #'restart-name r)))))))
pfdietz's avatar
pfdietz committed
97
       (restart-case
sds's avatar
sds committed
98 99 100
        (error "an error")
        (foo () 'bad)
        (foo () 'also-bad)))))
pfdietz's avatar
pfdietz committed
101 102
  nil nil)

pfdietz's avatar
pfdietz committed
103 104 105
;;; This test is disabled until I figure out how to fix
;;; it.  See sbcl-devel mailing list, Oct 2005
#|
106 107 108 109 110
(deftest compute-restarts.10
  (let ((c2 (make-condition 'error)))
    (block done
      (handler-bind
       ((error #'(lambda (c)
sds's avatar
sds committed
111 112 113 114 115 116 117 118 119
                   (declare (ignore c))
                   (let* ((restarts (compute-restarts c2))
                          (r (remove 'foo restarts
                                     :test-not #'eq
                                     :key #'restart-name)))
                     ;; (write restarts)
                     (return-from done
                       (values r
                               (mapcar #'restart-name r)))))))
120
       (restart-case
sds's avatar
sds committed
121 122 123 124 125
        (progn (error "an error"))
        (foo () :test (lambda (c) (or (null c) (not (eq c c2))))
             'bad)
        (foo () :test (lambda (c) (or (null c) (not (eq c c2))))
             'also-bad)))))
126
  nil nil)
pfdietz's avatar
pfdietz committed
127
|#
pfdietz's avatar
pfdietz committed
128 129 130 131