215 lines
4.9 KiB
Plaintext
215 lines
4.9 KiB
Plaintext
;; Function To Be Tested: catch & throw
|
|
;;
|
|
;; Source: CLtL Section 7.10. Dynamic Non-local Exits Page: 139
|
|
;;
|
|
;; Created By: Karin M. Sye
|
|
;;
|
|
;; Creation Date: Oct. 28 ,1986
|
|
;;
|
|
;; Last Update: Oct. 28 ,1986
|
|
;;
|
|
;; Filed As: {eris}<lispcore>cml>test>7-10-catch.test
|
|
;;
|
|
;;
|
|
;; Syntax: catch TAG {FORM}*
|
|
;;
|
|
;; Function Description: The catch special from serves as a target for transfer of control by throw. The form TAG is evaluated first
|
|
;; to produce an object that names the catch. A catch is then established with the object as the TAG.
|
|
;; The FORMs are evaluated as an implicit PROGN, and the results of the last form are returned, except that
|
|
;; if during the evaluation of the FORMS a throw should be executed such that the tag of the throw matches the
|
|
;; tag of the catch and the catcher is the most recent outstanding catcher with that tag, then the evaluation of
|
|
;; the FORMs is aborted and the results specified by the throw are immediately returned from the catch expression.
|
|
;;
|
|
;; Argument(s): TAG - a lisp form
|
|
;; FORM -
|
|
;;
|
|
;; Returns: anything
|
|
;;
|
|
|
|
(do-test "test catch - the body of catch is an implicit progn"
|
|
(and
|
|
(eq (catch 'cat ) nil)
|
|
(= (catch 'cat 1 2 3 4) 4)
|
|
(equal (multiple-value-list (catch 'foo
|
|
(block blk
|
|
(tagbody 1 2 3
|
|
(go exit)
|
|
4 5 6
|
|
exit (return-from blk (values 10 20 30))
|
|
(return-from blk 200) ))))
|
|
'(10 20 30))
|
|
)
|
|
)
|
|
|
|
|
|
(do-test-group ( "dynamic extent of tags"
|
|
:before (progn
|
|
;;
|
|
;; test cases copied from page 39 of CLtL
|
|
;;
|
|
(test-defun bar1 (x)
|
|
(catch 'trap (+ 3 (bar2 x))))
|
|
|
|
(test-defun bar2 (y)
|
|
(catch 'trap (* 5 (bar3 y))))
|
|
|
|
(test-defun bar3 (z)
|
|
(throw 'trap z))
|
|
;;
|
|
;;
|
|
(test-defun far1 (x)
|
|
(catch 'trap (+ 3 (far2 x))))
|
|
|
|
(test-defun far2 (y)
|
|
(catch 'trap9 (* 5 (far3 y))))
|
|
|
|
(test-defun far3 (z)
|
|
(throw 'trap z))
|
|
))
|
|
|
|
(do-test "test catch & throw - the tag of the throw matches the tag of the most recent outstanding catcher with that tag"
|
|
|
|
(and
|
|
|
|
(= (bar1 7) 10)
|
|
|
|
(= (far1 7) 7)
|
|
|
|
(let (var)
|
|
;;
|
|
;; this example also demonstrates that throw returns multiple values
|
|
;;
|
|
(equal (multiple-value-list
|
|
|
|
(catch 'cat
|
|
|
|
(catch 'dog
|
|
|
|
(catch 'cat
|
|
|
|
(catch 'cat
|
|
(push 'a var)
|
|
(throw 'cat (values var var)))
|
|
|
|
(push 'b var)
|
|
(throw 'cat (values var var)))
|
|
|
|
(push 'c var)
|
|
(throw 'cat (values var var)))
|
|
|
|
(push 'd var)
|
|
(throw 'cat (values var var))))
|
|
'((c b a) (c b a) ) )
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(do-test "test catch & throw - the tags of both catch & throw are evaluated"
|
|
|
|
(let ((b 10))
|
|
(= (catch (prog1 'cat (incf b 2) (decf b 10))
|
|
(setq b (* b b))
|
|
(throw (prog2 (incf b) 'cat (decf b 3)) b)) 2)
|
|
|
|
)
|
|
)
|
|
|
|
(do-test "test catch & throw - the result form is evaluated before the unwinding process commences"
|
|
|
|
(let ( (a '("path" )) (b '("path")) )
|
|
|
|
(declare (special a b))
|
|
|
|
(and
|
|
|
|
(equal (catch 'foo
|
|
(unwind-protect
|
|
(progn (nconc a '(unwfoo1))
|
|
(throw 'foo (nconc a '(throwfoo1)))
|
|
(nconc a '(wrongfoo1)))
|
|
(nconc a '(cleanupfoo1))
|
|
(nconc a '(cleanupfoo2))
|
|
)
|
|
(nconc a '(wrongfoo2)))
|
|
|
|
'("path" unwfoo1 throwfoo1 cleanupfoo1 cleanupfoo2))
|
|
|
|
(equal (catch 'bar
|
|
|
|
(block blk
|
|
|
|
(unwind-protect
|
|
(progn (nconc b '(unwbar1))
|
|
(return-from blk (nconc b '(returnbar1)))
|
|
(nconc b '(wrongbar1)))
|
|
;;
|
|
;; the cleanup forms of an unwind-protect are not protected by that unwind-protect
|
|
;;
|
|
(nconc b '(cleanupbar1))
|
|
(throw 'bar (nconc b '(cleanupbar2)))
|
|
(nconc b '(cleanupbar3))
|
|
)
|
|
(nconc b '(wrongbar2))
|
|
(nconc b '(wrongbar3)) ))
|
|
|
|
'("path" unwbar1 returnbar1 cleanupbar1 cleanupbar2))
|
|
|
|
;;
|
|
;; Page 142 of CLtL (In the process, dynamic variable bindings are undone back to the point of the catch)
|
|
;;
|
|
;;
|
|
;; (equal (list a b) '("path" "path"))
|
|
|
|
)
|
|
)
|
|
)
|
|
|
|
(do-test-group ("test catch & throw - when catcher is a function argument"
|
|
|
|
:before (progn
|
|
|
|
(test-defun getnum ()
|
|
(declare (special numlist))
|
|
(* 2 (getnum1)) )
|
|
|
|
(test-defun getnum1()
|
|
(declare (special numlist))
|
|
(throw 'catcher (pop numlist))
|
|
numlist )
|
|
|
|
(test-defun fool (m)
|
|
(let ( (numlist m) (newvar '()) )
|
|
|
|
(declare (special numlist))
|
|
|
|
(dotimes (x (length numlist) newvar)
|
|
;;
|
|
;; feed whatever returned from catcher to expt
|
|
;;
|
|
(push (expt (catch 'catcher (getnum)) 2) newvar) )
|
|
))
|
|
))
|
|
|
|
(do-test "test catch & throw - when catcher is a function argument"
|
|
|
|
(and (equal (fool '(2 3 4)) '(16 9 4))
|
|
(equal (fool '(10 20 30 40)) '(1600 900 400 100))
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
STOP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|