1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / mop-17.impure-cload.lisp
1 ;;;; miscellaneous side-effectful tests of the MOP
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 ;;; this file tests the programmatic class example from pp.67-69 of
15 ;;; AMOP.
16
17 (defpackage "MOP-17"
18   (:use "CL" "SB-MOP"))
19
20 (in-package "MOP-17")
21
22 (defun make-programmatic-instance (superclass-names &rest initargs)
23   (apply #'make-instance
24          (find-programmatic-class
25           (mapcar #'find-class superclass-names))
26          initargs))
27
28 (defun find-programmatic-class (superclasses)
29   (let ((class (find-if
30                  (lambda (class)
31                    (equal superclasses
32                           (class-direct-superclasses class)))
33                  (class-direct-subclasses (car superclasses)))))
34     (or class
35         (make-programmatic-class superclasses))))
36
37 (defun make-programmatic-class (superclasses)
38   (make-instance 'standard-class
39                  :name (mapcar #'class-name superclasses)
40                  :direct-superclasses superclasses
41                  :direct-slots '()))
42
43 (defclass shape () ())
44 (defclass circle (shape) ())
45 (defclass color () ())
46 (defclass orange (color) ())
47 (defclass magenta (color) ())
48 (defclass label-type () ())
49 (defclass top-labeled (label-type) ())
50 (defclass bottom-labeled (label-type) ())
51
52 (assert (null (class-direct-subclasses (find-class 'circle))))
53
54 (defvar *i1* (make-programmatic-instance '(circle orange top-labeled)))
55 (defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled)))
56 (defvar *i3* (make-programmatic-instance '(circle orange top-labeled)))
57
58 (assert (not (eq *i1* *i3*)))
59
60 (assert (= (length (class-direct-subclasses (find-class 'circle))) 2))