1.0.13.10: x86 MOVE-FROM-SIGNED & MOVE-FROM-UNSIGNED hackery
[sbcl/pkhuong.git] / tests / mop.impure-cload.lisp
blob5299d4f7f7b196c540a33ee09eef6712b9eee4d4
1 ;;;; miscellaneous side-effectful tests of the MOP
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.
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.
18 (defpackage "MOP-TEST"
19 (:use "CL" "SB-MOP"))
21 (in-package "MOP-TEST")
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")))
30 (defclass hyperobject-dsd (standard-direct-slot-definition)
31 ())
33 (defclass hyperobject-esd (standard-effective-slot-definition)
34 ((vc :initform 42)))
36 (defmethod validate-superclass ((class hyperobject-class)
37 (superclass standard-class))
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)))
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))
50 (defclass hyperobject ()
52 (:metaclass hyperobject-class))
54 (defclass person (hyperobject)
55 ((name :initarg :name :accessor person-name))
56 (:metaclass hyperobject-class))
59 (eval '(make-instance 'person :name t))