/[cmucl]/src/tests/mop-1.impure-cload.lisp
ViewVC logotype

Contents of /src/tests/mop-1.impure-cload.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Wed Feb 2 16:03:18 2005 UTC (9 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2007-01, snapshot-2007-02, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, RELEASE_20b, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Initial revision.
1 rtoy 1.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     ;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
19     ;;; fixups for running in the full MOP rather than closette: SLOTDs
20     ;;; instead of slot-names, and so on.
21    
22     (defpackage "TEST" (:use "CL" #+sbcl "SB-MOP" #+pcl "PCL"))
23     (in-package "TEST")
24    
25     (defclass dynamic-slot-class (standard-class) ())
26    
27     (defmethod validate-superclass
28     ((class dynamic-slot-class) (super standard-class))
29     t)
30    
31     (defmethod compute-effective-slot-definition
32     ((class dynamic-slot-class) name direct-slots)
33     (let ((slot (call-next-method)))
34     (setf (slot-definition-allocation slot) :dynamic)
35     slot))
36    
37     (defun dynamic-slot-p (slot)
38     (eq (slot-definition-allocation slot) :dynamic))
39    
40     (let ((table (make-hash-table)))
41    
42     (defun allocate-table-entry (instance)
43     (setf (gethash instance table) ()))
44    
45     (defun read-dynamic-slot-value (instance slot-name)
46     (let* ((alist (gethash instance table))
47     (entry (assoc slot-name alist)))
48     (if (null entry)
49     (error "slot ~S unbound in ~S" slot-name instance)
50     (cdr entry))))
51    
52     (defun write-dynamic-slot-value (new-value instance slot-name)
53     (let* ((alist (gethash instance table))
54     (entry (assoc slot-name alist)))
55     (if (null entry)
56     (push `(,slot-name . ,new-value)
57     (gethash instance table))
58     (setf (cdr entry) new-value))
59     new-value))
60    
61     (defun dynamic-slot-boundp (instance slot-name)
62     (let* ((alist (gethash instance table))
63     (entry (assoc slot-name alist)))
64     (not (null entry))))
65    
66     (defun dynamic-slot-makunbound (instance slot-name)
67     (let* ((alist (gethash instance table))
68     (entry (assoc slot-name alist)))
69     (unless (null entry)
70     (setf (gethash instance table) (delete entry alist))))
71     instance)
72    
73     )
74    
75     (defmethod allocate-instance ((class dynamic-slot-class) &key)
76     (let ((instance (call-next-method)))
77     (allocate-table-entry instance)
78     instance))
79    
80     (defmethod slot-value-using-class ((class dynamic-slot-class)
81     instance slotd)
82     (let ((slot (find slotd (class-slots class))))
83     (if slot
84     (read-dynamic-slot-value instance (slot-definition-name slotd))
85     (call-next-method))))
86    
87     (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
88     instance slotd)
89     (let ((slot (find slotd (class-slots class))))
90     (if slot
91     (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
92     (call-next-method))))
93    
94     (defmethod slot-boundp-using-class ((class dynamic-slot-class)
95     instance slotd)
96     (let ((slot (find slotd (class-slots class))))
97     (if slot
98     (dynamic-slot-boundp instance (slot-definition-name slotd))
99     (call-next-method))))
100    
101     (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
102     instance slotd)
103     (let ((slot (find slotd (class-slots class))))
104     (if slot
105     (dynamic-slot-makunbound instance (slot-definition-name slotd))
106     (call-next-method))))
107    
108     (defclass test-class-1 ()
109     ((slot1 :initarg :slot1)
110     (slot2 :initarg :slot2 :initform nil))
111     (:metaclass dynamic-slot-class))
112    
113     (defclass test-class-2 (test-class-1)
114     ((slot2 :initarg :slot2 :initform t)
115     (slot3 :initarg :slot3))
116     (:metaclass dynamic-slot-class))
117    
118     (defvar *one* (make-instance 'test-class-1))
119     (defvar *two* (make-instance 'test-class-2 :slot3 1))
120    
121     (assert (not (slot-boundp *one* 'slot1)))
122     (assert (null (slot-value *one* 'slot2)))
123     (assert (eq t (slot-value *two* 'slot2)))
124     (assert (= 1 (slot-value *two* 'slot3)))
125    

  ViewVC Help
Powered by ViewVC 1.1.5