0.9.1.16:
[sbcl.git] / tests / condition.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
6 ;;;; from CMU CL.
7 ;;;;
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
11
12 (cl:in-package :cl-user)
13
14 ;;; Bug from CLOCC.
15 (defpackage :p1
16   (:use :cl)
17   (:export #:code #:code-msg #:%code-msg))
18 (in-package :p1)
19 (define-condition code ()
20   ((msg :reader code-msg :reader %code-msg :initarg :msg)))
21
22 (defpackage :p2
23   (:use :cl :p1))
24 (in-package :p2)
25 (define-condition code1 (code)
26   ((msg :accessor code-msg :initarg :msg)))
27
28 (let ((code (make-condition 'code :msg 1)))
29   (assert (typep code 'code))
30   (assert (eql (code-msg code) 1))
31   (assert (eql (%code-msg code) 1)))
32 (let ((code (make-condition 'code1 :msg 1)))
33   (assert (typep code 'code))
34   (assert (eql (code-msg code) 1))
35   (assert (eql (%code-msg code) 1))
36   (setf (code-msg code) 2)
37   (assert (eql (code-msg code) 2))
38   (assert (eql (%code-msg code) 1)))
39
40 ;;; Check that initializing the condition class metaobject doesn't create
41 ;;; any instances. Reported by Marco Baringer on sbcl-devel Mon, 05 Jul 2004.
42 (defvar *condition-count* 0)
43 (define-condition counted-condition () ((slot :initform (incf *condition-count*))))
44 (defmethod frob-counted-condition ((x counted-condition)) x)
45 (assert (= 0 *condition-count*))
46 (assert (typep (sb-mop:class-prototype (find-class 'counted-condition))
47                '(and condition counted-condition)))
48
49 ;;; success
50 (sb-ext:quit :unix-status 104)