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))