1;;;; Common Lisp Object System for CLISP
2;;;; Slot Definition metaobjects
3;;;; Part n-2: Final class definitions, make/initialize-instance methods.
4;;;; Bruno Haible 2004-04-18
5
6(in-package "CLOS")
7
8;;; ===========================================================================
9
10;;; Lift the initialization protocol.
11
12(defmethod initialize-instance ((slotdef slot-definition) &rest args
13                                &key name initform initfunction initargs
14                                     type allocation documentation
15                                     ((inheritable-initer inheritable-initer))
16                                     ((inheritable-doc inheritable-doc)))
17  (declare (ignore name initform initfunction initargs type allocation
18                   documentation inheritable-initer inheritable-doc))
19  (apply #'initialize-instance-<slot-definition> slotdef args))
20
21(defmethod initialize-instance ((slotdef direct-slot-definition) &rest args
22                                &key name initform initfunction initargs
23                                     type allocation documentation
24                                     ((inheritable-initer inheritable-initer))
25                                     ((inheritable-doc inheritable-doc))
26                                     readers writers
27                                     ((defclass-form defclass-form)))
28  (declare (ignore name initform initfunction initargs type allocation
29                   documentation inheritable-initer inheritable-doc readers
30                   writers defclass-form))
31  (apply #'initialize-instance-<direct-slot-definition> slotdef args))
32
33(defmethod initialize-instance ((slotdef effective-slot-definition) &rest args
34                                &key name initform initfunction initargs
35                                     type allocation documentation
36                                     ((inheritable-initer inheritable-initer))
37                                     ((inheritable-doc inheritable-doc)))
38  (declare (ignore name initform initfunction initargs type allocation
39                   documentation inheritable-initer inheritable-doc))
40  (apply #'initialize-instance-<effective-slot-definition> slotdef args))
41
42(defmethod reinitialize-instance ((instance slot-definition) &rest initargs)
43  (declare (ignore initargs))
44  (error (TEXT "~S: The MOP does not allow reinitializing ~S")
45         'reinitialize-instance instance))
46
47
48;;; ===========================================================================
49
50;;; Now the concrete classes for <standard-class> and <structure-class> slots.
51
52;;; ---------------------------------------------------------------------------
53
54(defmethod initialize-instance ((slotdef standard-direct-slot-definition) &rest args)
55  (apply #'initialize-instance-<standard-direct-slot-definition> slotdef args))
56
57;;; ---------------------------------------------------------------------------
58
59(defmethod initialize-instance ((slotdef standard-effective-slot-definition) &rest args)
60  (apply #'initialize-instance-<standard-effective-slot-definition> slotdef args))
61
62;;; ---------------------------------------------------------------------------
63
64(defmethod initialize-instance ((slotdef structure-direct-slot-definition) &rest args)
65  (apply #'initialize-instance-<structure-direct-slot-definition> slotdef args))
66
67;;; ---------------------------------------------------------------------------
68
69(defun structure-effective-slot-definition-readonly (slotdef)
70  (slot-value slotdef '$readonly))
71(defun (setf structure-effective-slot-definition-readonly) (new-value slotdef)
72  (setf (slot-value slotdef '$readonly) new-value))
73(defmethod initialize-instance ((slotdef structure-effective-slot-definition) &rest args)
74  (apply #'initialize-instance-<structure-effective-slot-definition> slotdef args))
75
76;;; ===========================================================================
77
78;; Now that all the predefined subclasses of <slot-definition> have been
79;; defined, CLASS-OF can work on all existing <slot-definition> instances.
80;; Therefore now, not earlier, it's possible to pass these <slot-definition>
81;; instances to generic functions.
82