1
;;;; Copyright (c) 1992, Giuseppe Attardi.
3
;;;; This program is free software; you can redistribute it and/or
4
;;;; modify it under the terms of the GNU Library General Public
5
;;;; License as published by the Free Software Foundation; either
6
;;;; version 2 of the License, or (at your option) any later version.
8
;;;; See file '../Copyright' for full details.
12
;;; ----------------------------------------------------------------------
13
;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS.
15
;;; We cannot use the functions CREATE-STANDARD-CLASS and others because SLOTS,
16
;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work.
18
(defun make-empty-standard-class (name metaclass)
19
(let ((class (si:allocate-raw-instance nil metaclass #.(length +standard-class-slots+))))
21
(si:instance-class-set class class))
22
(setf (class-id class) name
23
(class-direct-superclasses class) nil
24
(class-direct-subclasses class) nil
25
(class-slots class) nil
26
(class-direct-slots class) nil
27
(class-direct-default-initargs class) nil
28
(class-default-initargs class) nil
29
(class-precedence-list class) nil
30
(class-finalized-p class) t
31
(find-class name) class)
33
(setf (slot-table class) (make-hash-table :size 2)))
36
;; 1) Create the classes
38
;; Notice that, due to circularity in the definition, STANDARD-CLASS has
39
;; itself as metaclass. MAKE-EMPTY-CLASS takes care of that.
41
(let* ((standard-class (make-empty-standard-class 'STANDARD-CLASS nil))
42
(standard-object (make-empty-standard-class 'STANDARD-OBJECT standard-class))
43
(the-class (make-empty-standard-class 'CLASS standard-class))
44
(the-t (make-empty-standard-class 'T the-class))
45
;; It does not matter that we pass NIL instead of a class object,
46
;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots.
47
(class-slots (loop for s in (parse-slots '#.+class-slots+)
48
collect (canonical-slot-to-direct-slot nil s)))
49
(standard-slots (loop for s in (parse-slots '#.+standard-class-slots+)
50
collect (canonical-slot-to-direct-slot nil s)))
51
(hash-table (make-hash-table :size 24)))
53
;; 2) STANDARD-CLASS and CLASS are the only classes with slots. Create a
54
;; hash table for them, so that SLOT-VALUE works. Notice that we
55
;; make a intentional mistake: CLASS and STANDARD-CLASS share the same
58
(slots standard-slots (cdr slots)))
60
(let ((slotd (first slots)))
61
(setf (slot-definition-location slotd) i)
62
(setf (gethash (slot-definition-name slotd) hash-table) slotd)))
63
(dolist (slotd class-slots)
64
(setf (slot-definition-location slotd)
65
(slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
66
(setf (class-slots the-class) (copy-list class-slots)
67
(slot-table the-class) hash-table
68
(class-direct-slots the-class) class-slots
69
(class-slots standard-class) standard-slots
70
(slot-table standard-class) hash-table
71
(class-direct-slots standard-class) (set-difference standard-slots class-slots))
73
;; 3) Fix the class hierarchy
74
(setf (class-direct-superclasses the-t) nil
75
(class-direct-subclasses the-t) (list standard-object)
76
(class-direct-superclasses standard-object) (list the-t)
77
(class-direct-subclasses standard-object) (list the-class)
78
(class-direct-superclasses the-class) (list standard-object)
79
(class-direct-subclasses the-class) (list standard-class)
80
(class-direct-superclasses standard-class) (list the-class))
82
(si::instance-sig-set the-class)
83
(si::instance-sig-set standard-class)
84
(si::instance-sig-set standard-object)
85
(si::instance-sig-set the-t)
87
;; 4) Fix the class precedence list
88
(let ((cpl (list standard-class the-class standard-object the-t)))
89
(setf (class-precedence-list standard-class) cpl
90
(class-precedence-list the-class) (cdr cpl)
91
(class-precedence-list standard-object) (cddr cpl)
92
(class-precedence-list the-t) nil))
94
;; 5) Generate accessors (In macros.lsp)
97
(defconstant +the-standard-class+ (find-class 'standard nil))
99
(defmethod class-prototype ((class class))
100
(unless (slot-boundp class 'prototype)
101
(setf (slot-value class 'prototype) (allocate-instance class)))
102
(slot-value class 'prototype))
104
;;; ----------------------------------------------------------------------
105
;;; SLOTS READING AND WRITING
108
;;; 1) Functional interface
111
(defun find-slot-definition (class slot-name)
112
(declare (si::c-local))
113
(if (eq (si:instance-class class) +the-standard-class+)
114
(gethash (class-slot-table class) slot-name nil)
115
(find slot-name (class-slots class) :key #'slot-definition-name)))
117
(defun slot-value (self slot-name)
118
(let* ((class (class-of self))
119
(slotd (find-slot-definition class slot-name)))
121
(slot-value-using-class class self slotd)
122
(values (slot-missing class self slot-name 'SLOT-VALUE)))))
124
(defun slot-boundp (self slot-name)
125
(let* ((class (class-of self))
126
(slotd (find-slot-definition class slot-name)))
128
(slot-boundp-using-class class self slotd)
129
(values (slot-missing class self slot-name 'SLOT-BOUNDP)))))
131
(defun (setf slot-value) (value self slot-name)
132
(let* ((class (class-of self))
133
(slotd (find-slot-definition class slot-name)))
135
(funcall #'(setf slot-value-using-class) value class self slotd)
136
(slot-missing class self slot-name 'SETF value))
139
(defun slot-makunbound (self slot-name)
140
(let* ((class (class-of self))
141
(slotd (find-slot-definition class slot-name)))
143
(slot-makunbound-using-class class self slotd)
144
(slot-missing class self slot-name 'SLOT-MAKUNBOUND))
147
(defun slot-exists-p (self slot-name)
148
(and (find-slot-definition (class-of self) slot-name)
152
;;; 2) Overloadable methods on which the previous functions are based
155
(defun standard-instance-get (instance slotd)
156
(ensure-up-to-date-instance instance)
157
(let* ((class (si:instance-class instance))
158
(location (slot-definition-location slotd)))
159
(cond ((si:fixnump location)
161
(si:instance-ref instance (the fixnum location)))
166
(error "Effective slot definition lacks a valid location:~%~A"
169
(defun standard-instance-set (val instance slotd)
170
(ensure-up-to-date-instance instance)
171
(let* ((class (si:instance-class instance))
172
(location (slot-definition-location slotd)))
173
(cond ((si:fixnump location)
175
(si:instance-set instance (the fixnum location) val))
178
(setf (car location) val))
180
(error "Effective slot definition lacks a valid location:~%~A"
184
(defmethod slot-value-using-class ((class class) self slotd)
185
(let ((value (standard-instance-get self slotd)))
186
(if (si:sl-boundp value)
188
(values (slot-unbound class self (slot-definition-name slotd))))))
190
(defmethod slot-boundp-using-class ((class class) self slotd)
191
(si::sl-boundp (standard-instance-get self slotd)))
193
(defmethod (setf slot-value-using-class) (val (class class) self slotd)
194
(standard-instance-set val self slotd))
196
(defmethod slot-makunbound-using-class ((class class) instance slotd)
197
(ensure-up-to-date-instance instance)
198
(let* ((location (slot-definition-location slotd)))
199
(cond ((si:fixnump location)
201
(si:sl-makunbound instance (the fixnum location)))
204
(setf (car location) (unbound)))
206
(error "Effective slot definition lacks a valid location:~%~A"
211
;;; 3) Error messages related to slot access
214
(defmethod slot-missing ((class t) object slot-name operation
216
(declare (ignore operation new-value))
217
(error "~A is not a slot of ~A" slot-name object))
219
(defmethod slot-unbound ((class t) object slot-name)
220
(error 'unbound-slot :instance object :name slot-name))
223
;;; For the next accessor we define a method.
226
(defmethod class-name ((class class))
229
(defmethod (setf class-name) (new-value (class class))
230
(setf (class-id class) new-value))
added
removed
src/clos/boot.lsp
