home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / tests / conditions.tst < prev    next >
Encoding:
Text File  |  1996-04-15  |  9.1 KB  |  359 lines
  1. ;;;; Test suite for the Common Lisp condition system
  2. ;;;; Written by David Gadbois <gadbois@cs.utexas.edu> 30.11.1993
  3.  
  4. ;;;
  5. ;;; Helpers
  6. ;;;
  7.  
  8. (defun check-superclasses (class expected)
  9.   (let ((expected (list* class 't 'clos:standard-object 'condition expected))
  10.         (super (mapcar #'clos:class-name (clos::class-precedence-list (clos:find-class class)))))
  11.     (and (null (set-difference super expected))
  12.          (null (set-difference expected super)))))
  13. CHECK-SUPERCLASSES
  14.  
  15. ;;;
  16. ;;; IGNORE-ERRORS
  17. ;;;
  18. ;;; If this does not work, none of the tests that check for getting an error
  19. ;;; will.
  20.  
  21. ;;; IGNORE-ERRORS should work.
  22. (multiple-value-bind (value condition)
  23.     (ignore-errors (error "Foo"))
  24.   (list value (type-of condition)))
  25. (nil simple-error)
  26.  
  27. ;;; IGNORE-ERRORS should not interfere with values in non-error situations.
  28. (multiple-value-list
  29.     (ignore-errors (values 23 42)))
  30. (23 42)
  31.  
  32. ;;;
  33. ;;; Predefined condition types.
  34. ;;;
  35.  
  36. (check-superclasses 'warning '()) T
  37. #+dpANS (check-superclasses 'style-warning '(warning)) #+dpANS T
  38. (check-superclasses 'serious-condition '()) T
  39. (check-superclasses 'error '(serious-condition)) T
  40. (check-superclasses 'cell-error '(error serious-condition)) T
  41. #+dpANS (check-superclasses 'parse-error '(error serious-condition)) #+dpANS T
  42. (check-superclasses 'storage-condition '(serious-condition)) T
  43. (check-superclasses 'simple-error '(simple-condition error serious-condition)) T
  44. (check-superclasses 'simple-condition '()) T
  45. (check-superclasses 'simple-warning '(simple-condition warning)) T
  46. (check-superclasses 'file-error '(error serious-condition)) T
  47. (check-superclasses 'control-error '(error serious-condition)) T
  48. (check-superclasses 'program-error '(error serious-condition)) T
  49. (check-superclasses 'undefined-function '(cell-error error serious-condition)) T
  50. (check-superclasses 'arithmetic-error '(error serious-condition)) T
  51. (check-superclasses 'division-by-zero '(arithmetic-error error serious-condition)) T
  52. #+dpANS (check-superclasses 'floating-point-invalid-operation '(arithmetic-error error serious-condition)) #+dpANS T
  53. #+dpANS (check-superclasses 'floating-point-inexact '(arithmetic-error error serious-condition)) #+dpANS T
  54. (check-superclasses 'floating-point-overflow '(arithmetic-error error serious-condition)) T
  55. (check-superclasses 'floating-point-underflow '(arithmetic-error error serious-condition)) T
  56. #+dpANS (check-superclasses 'unbound-slot '(cell-error error serious-condition)) #+dpANS T
  57. (check-superclasses 'package-error '(error serious-condition)) T
  58. #+dpANS (check-superclasses 'print-not-readable '(error serious-condition)) #+dpANS T
  59. #+dpANS (check-superclasses 'reader-error '(parse-error stream-error error serious-condition)) #+dpANS T
  60. (check-superclasses 'stream-error '(error serious-condition)) T
  61. (check-superclasses 'end-of-file '(stream-error error serious-condition)) T
  62. (check-superclasses 'unbound-variable '(cell-error error serious-condition)) T
  63. (check-superclasses 'type-error '(error serious-condition)) T
  64. (check-superclasses 'simple-type-error '(#-dpANS simple-error simple-condition type-error error serious-condition)) T
  65.  
  66. ;;;
  67. ;;; Defining conditions.
  68. ;;;
  69. (progn (define-condition test () ()) t)
  70. T
  71.  
  72. (check-superclasses  'test '())
  73. T
  74.  
  75. (progn (define-condition test2 (test) ()) t)
  76. T
  77.  
  78. (check-superclasses 'test2 '(test))
  79. T
  80.  
  81. (progn (define-condition test3 (test2 simple-condition) ()) t)
  82. T
  83.  
  84. (check-superclasses 'test3 '(test2 test simple-condition))
  85. T
  86.  
  87. ;;;
  88. ;;; Making conditions
  89. ;;;
  90. (progn (make-condition 'test) t)
  91. T
  92.  
  93. (ignore-errors (progn (make-condition 'integer) t))
  94. NIL
  95.  
  96. ;;;
  97. ;;; :REPORT option to DEFINE-CONDITION
  98. ;;;
  99. (progn (define-condition test4 (test3)
  100.          ()
  101.          (:report (lambda (condition stream)
  102.                     (format stream "Yow! -- ~S" (type-of condition)))))
  103.        t)
  104. T
  105.  
  106. (with-output-to-string (s) (princ (make-condition 'test4) s))
  107. "Yow! -- TEST4"
  108.  
  109. (progn (define-condition test5 (test4) ()) t)
  110. T
  111.  
  112. (with-output-to-string (s) (princ (make-condition 'test5) s))
  113. "Yow! -- TEST5"
  114.  
  115. (with-output-to-string (s)
  116.   (princ (make-condition 'test3 :format-string "And How! -- ~S"
  117.                                 :format-arguments '(23)) s))
  118. "And How! -- 23"
  119.  
  120. ;;;
  121. ;;; Condition slots.
  122. ;;;
  123. (progn (define-condition test6 (test4)
  124.          ((foo :initarg :foo :initform 23 :accessor test6-foo))
  125.          (:report (lambda (condition stream)
  126.                     (format stream "~S -- ~S"
  127.                             (type-of condition)
  128.                             (test6-foo condition)))))
  129.        t)
  130. T
  131.  
  132. (test6-foo (make-condition 'test6))
  133. 23
  134.  
  135. (test6-foo (make-condition 'test6 :foo 42))
  136. 42
  137.  
  138. (setf (test6-foo (make-condition 'test6 :foo 42)) 17)
  139. 17
  140.  
  141. (with-output-to-string (s) (princ (make-condition 'test6 :foo 42) s))
  142. "TEST6 -- 42"
  143.  
  144. ;;;
  145. ;;; HANDLER-BIND
  146. ;;;
  147.  
  148. ;;; You do not have to bind handlers.
  149. (ignore-errors
  150.  (handler-bind
  151.      ()
  152.    (error "Foo")))
  153. nil
  154.  
  155. ;;; Handlers should not interfere with values in non-error situations.
  156. (multiple-value-list
  157.     (block foo
  158.       (handler-bind
  159.           ((error #'(lambda (c)
  160.                       (declare (ignore c))
  161.                       (return-from foo 23))))
  162.         (values 42 17))))
  163. (42 17)
  164.  
  165. ;;; Handlers should work.
  166. (multiple-value-list
  167.     (block foo
  168.       (handler-bind 
  169.           ((error #'(lambda (c)
  170.                       (declare (ignore c))
  171.                       (return-from foo (values 23 17)))))
  172.         (error "Foo"))))
  173. (23 17)
  174.  
  175. ;;; Only the appropriate handlers should be called.
  176. (ignore-errors
  177.  (block foo
  178.    (handler-bind 
  179.        ((type-error #'(lambda (c)
  180.                         (declare (ignore c))
  181.                         (return-from foo 23))))
  182.      (error "Foo"))))
  183. nil
  184.  
  185. ;;; Handlers can be specified type expressions.
  186. (block foo
  187.   (handler-bind 
  188.       (((or type-error error)
  189.         #'(lambda (c)
  190.             (declare (ignore c))
  191.             (return-from foo 23))))
  192.     (error "Foo")))
  193. 23
  194.  
  195. ;;; Handlers should be undone.
  196. (ignore-errors
  197.  (block foo
  198.    (let ((first-time t))
  199.      (handler-bind 
  200.          ((error
  201.            #'(lambda (c)
  202.                (declare (ignore c))
  203.                (if first-time
  204.                    (progn
  205.                      (setq first-time nil)
  206.                      (error "Bar"))
  207.                    (return-from foo 23)))))
  208.        (error "Foo")))))
  209. nil
  210.  
  211. ;;; Handlers should be undone.
  212. (block foo
  213.   (let ((first-time t))
  214.     (handler-bind
  215.         ((error
  216.           #'(lambda (c)
  217.               (declare (ignore c))
  218.               (return-from foo 23))))
  219.       (handler-bind
  220.           ((error 
  221.             #'(lambda (c)
  222.                 (declare (ignore c))
  223.                 (if first-time
  224.                     (progn
  225.                       (setq first-time nil)
  226.                       (error "Bar"))
  227.                     (return-from foo 42)))))
  228.         (error "Foo")))))
  229. 23
  230.  
  231. ;;; Handlers in the same cluster should be accessible.
  232. (ignore-errors
  233.  (block foo
  234.    (handler-bind 
  235.        ((error
  236.          #'(lambda (c) (declare (ignore c)) nil))
  237.         (error
  238.          #'(lambda (c)
  239.              (declare (ignore c))
  240.              (return-from foo 23))))
  241.      (error "Foo"))))
  242. #-dpANS nil #+dpANS 23
  243.  
  244. ;;; Multiple handlers should work.
  245. (block foo
  246.   (handler-bind 
  247.       ((type-error
  248.         #'(lambda (c) 
  249.             (declare (ignore c))
  250.             (return-from foo 42)))
  251.        (error
  252.         #'(lambda (c)
  253.             (declare (ignore c))
  254.             (return-from foo 23))))
  255.     (error "Foo")))
  256. 23
  257.  
  258. ;;; Handlers should be undone.
  259. (block foo
  260.   (handler-bind
  261.       ((error #'(lambda (c)
  262.                   (declare (ignore c))
  263.                   (return-from foo 23))))
  264.     (block bar
  265.       (handler-bind
  266.           ((error #'(lambda (c)
  267.                       (declare (ignore c))
  268.                       (return-from foo 42))))
  269.         (return-from bar)))
  270.     (error "Foo")))
  271. 23
  272.  
  273. ;;;
  274. ;;; HANDLER-CASE
  275. ;;;
  276.  
  277. ;;; HANDLER-CASE should handle errors.
  278. (multiple-value-list
  279.     (handler-case 
  280.         (error "Foo")
  281.       (error (c) (when (typep c 'error) (values 23 42)))))
  282. (23 42)
  283.  
  284. ;;; Except those it doesn't handle.
  285. (ignore-errors
  286.  (handler-case
  287.      (error "Foo")
  288.    (type-error () 23)))
  289. NIL
  290.  
  291. ;;; You don't have to specify handlers.
  292. (ignore-errors
  293.  (handler-case
  294.      (error "Foo")))
  295. NIL
  296.  
  297. ;;; HANDLER-CASE should not interfere with values in non-error situations.
  298. (multiple-value-list
  299.     (handler-case
  300.         (values 42 17)
  301.       (error () 23)))
  302. (42 17)
  303.  
  304. ;;; :NO-ERROR should return values.
  305. (multiple-value-list
  306.     (handler-case
  307.         (values 23 42)
  308.       (:no-error (a b)
  309.         (values b a))))
  310. (42 23)
  311.  
  312. ;;; Except when there is an error.
  313. (handler-case
  314.     (error "Foo")
  315.   (error () 23)
  316.   (:no-error (&rest args) (declare (ignore args)) 42))
  317. 23
  318.  
  319. ;;; Or if it is not the last clause.
  320. (handler-case
  321.     23
  322.   (:no-error (v) (1+ v))
  323.   (error () 42))
  324. 23
  325.  
  326. ;;; Multiple handlers should be OK.
  327. (handler-case
  328.     (error "Foo")
  329.   (type-error () 23)
  330.   (error () 42))
  331. 42
  332.  
  333. ;;; Handlers should get undone.
  334. (ignore-errors
  335.  (progn 
  336.    (block foo
  337.      (handler-case
  338.          (return-from foo 23)
  339.        (error () 42)))
  340.    (error "Foo")))
  341. NIL
  342.  
  343. ;;; Ditto.
  344. (ignore-errors
  345.  (block foo
  346.    (let ((first-time t))
  347.      (handler-case
  348.          (error "Foo")
  349.        (error ()
  350.          (if first-time
  351.              (progn
  352.                (setf first-time nil)
  353.                (error "Bar"))
  354.              (return-from foo 23)))))))
  355. NIL
  356.       
  357.  
  358.  
  359.