unwind-protect.lsp 2.59 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Oct 12 14:41:16 2002
;;;; Contains: Tests of UNWIND-PROTECT

(in-package :cl-test)

(deftest unwind-protect.1
  (let ((x nil))
    (unwind-protect
sds's avatar
sds committed
11
        (push 1 x)
12 13 14 15 16 17 18
      (incf (car x))))
  (2))

(deftest unwind-protect.2
  (let ((x nil))
    (block foo
      (unwind-protect
sds's avatar
sds committed
19 20
          (progn (push 1 x) (return-from foo x))
        (incf (car x)))))
21 22 23 24 25 26
  (2))

(deftest unwind-protect.3
  (let ((x nil))
    (tagbody
      (unwind-protect
sds's avatar
sds committed
27 28
          (progn (push 1 x) (go done))
        (incf (car x)))
29 30 31 32 33 34 35 36
      done)
    x)
  (2))

(deftest unwind-protect.4
  (let ((x nil))
    (catch 'done
      (unwind-protect
sds's avatar
sds committed
37 38
          (progn (push 1 x) (throw 'done x))
        (incf (car x)))))
39 40 41 42 43 44
  (2))

(deftest unwind-protect.5
  (let ((x nil))
    (ignore-errors
      (unwind-protect
sds's avatar
sds committed
45 46
          (progn (push 1 x) (error "Boo!"))
        (incf (car x))))
47 48 49 50 51 52 53
    x)
  (2))

(deftest unwind-protect.6
  (let ((x nil))
    (block done
      (flet ((%f () (return-from done nil)))
sds's avatar
sds committed
54 55
        (unwind-protect (%f)
          (push 'a x))))
56 57 58 59 60 61 62
    x)
  (a))

(deftest unwind-protect.7
  (let ((x nil))
    (block done
      (flet ((%f () (return-from done nil)))
sds's avatar
sds committed
63 64 65 66
        (unwind-protect
            (unwind-protect (%f)
              (push 'b x))
          (push 'a x))))
67 68 69 70 71 72 73
    x)
  (a b))

(deftest unwind-protect.8
  (let ((x nil))
    (block done
      (unwind-protect
sds's avatar
sds committed
74 75 76 77 78 79
          (flet ((%f () (return-from done nil)))
            (unwind-protect
                (unwind-protect (%f)
                  (push 'b x))
              (push 'a x)))
        (push 'c x)))
80 81 82 83 84 85 86
    x)
  (c a b))

(deftest unwind-protect.9
  (let ((x nil))
    (handler-case
      (flet ((%f () (error 'type-error :datum 'foo :expected-type nil)))
sds's avatar
sds committed
87 88
        (unwind-protect (handler-case (%f))
          (push 'a x)))
89 90
      (type-error () x)))
  (a))
91 92 93 94 95 96

;;; No implicit tagbody
(deftest unwind-protect.10
  (block done
    (tagbody
     (unwind-protect
sds's avatar
sds committed
97
         'foo
98 99 100 101 102 103
       (go 10)
       10
       (return-from done 'bad))
     10
     (return-from done 'good)))
  good)
104 105 106 107 108 109 110

;;; Executes all forms of the implicit progn
(deftest unwind-protect.11
  (let ((x nil) (y nil))
    (values
     (block nil
       (unwind-protect (return 'a)
sds's avatar
sds committed
111 112
         (setf y 'c)
         (setf x 'b)))
113 114 115
     x y))
  a b c)

116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest unwind-protect.12
  (macrolet
   ((%m (z) z))
   (unwind-protect (expand-in-current-env (%m :good)) :bad))
  :good)

(deftest unwind-protect.13
  (macrolet
   ((%m (z) z))
   (unwind-protect :good (expand-in-current-env (%m :bad))))
  :good)