tests/mop.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 ;;;; Note that the MOP is not in an entirely supported state.
  15 ;;;; However, this seems a good a way as any of ensuring that we have
  16 ;;;; no regressions.
  17
  18 (defpackage "MOP-TEST"
  19   (:use "CL" "SB-MOP"))
  20
  21 (in-package "MOP-TEST")
  22
  23 ;;; A distilled test case from cmucl-imp for Kevin Rosenberg's
  24 ;;; hyperobject.  Fix from Gerd Moellmann.
  25 (defclass hyperobject-class (standard-class)
  26   ((user-name :initarg :user-name :type (or null string) :initform nil
  27               :accessor user-name
  28               :documentation "User name for class")))
  29
  30 (defclass hyperobject-dsd (standard-direct-slot-definition)
  31   ())
  32
  33 (defclass hyperobject-esd (standard-effective-slot-definition)
  34   ((vc :initform 42)))
  35
  36 (defmethod validate-superclass ((class hyperobject-class)
  37                                 (superclass standard-class))
  38   t)
  39
  40 (defmethod compute-effective-slot-definition :around
  41     ((cl hyperobject-class) name dsds)
  42   (let ((ia (sb-pcl::compute-effective-slot-definition-initargs cl dsds)))
  43     (apply #'make-instance 'hyperobject-esd ia)))
  44
  45 (defmethod (setf slot-value-using-class) :around
  46     (new-value (cl hyperobject-class) obj (slot hyperobject-esd))
  47   (format t "~s ~s ~s~%" cl obj slot)
  48   (slot-value slot 'vc))
  49
  50 (defclass hyperobject ()
  51   ()
  52   (:metaclass hyperobject-class))
  53
  54 (defclass person (hyperobject)
  55   ((name :initarg :name :accessor person-name))
  56   (:metaclass hyperobject-class))
  57
  58
  59 (eval '(make-instance 'person :name t))