0.6.7.22: removed CVS dollar-Header-dollar tags from sources
[sbcl.git] / src / pcl / structure-class.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (defmethod initialize-internal-slot-functions :after
27           ((slotd structure-effective-slot-definition))
28   (let ((name (slot-definition-name slotd)))
29     (initialize-internal-slot-reader-gfs name)
30     (initialize-internal-slot-writer-gfs name)
31     (initialize-internal-slot-boundp-gfs name)))
32
33 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
34   :instance)
35
36 (defmethod class-prototype ((class structure-class))
37   (with-slots (prototype) class
38     (or prototype
39         (setq prototype (make-class-prototype class)))))
40
41 (defmethod make-class-prototype ((class structure-class))
42   (with-slots (wrapper defstruct-constructor) class
43     (if defstruct-constructor
44         (make-instance class)
45       (let* ((proto (%allocate-instance--class *empty-vector*)))
46          (shared-initialize proto T :check-initargs-legality-p NIL)
47          (setf (std-instance-wrapper proto) wrapper)
48          proto))))
49
50 (defmethod make-direct-slotd ((class structure-class)
51                               &rest initargs
52                               &key
53                               (name (error "Slot needs a name."))
54                               (conc-name (class-defstruct-conc-name class))
55                               (defstruct-accessor-symbol () acc-sym-p)
56                               &allow-other-keys)
57   (declare (ignore defstruct-accessor-symbol))
58   (declare (type symbol name)
59            (type simple-string conc-name))
60   (let ((initargs (list* :class class :allow-other-keys T initargs)))
61     (unless acc-sym-p
62       (setf initargs
63             (list* :defstruct-accessor-symbol
64                    (intern (concatenate 'simple-string conc-name (symbol-name name))
65                            (symbol-package (class-name class)))
66                    initargs)))
67     (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
68
69 (defun slot-definition-defstruct-slot-description (slot)
70   (let ((type (slot-definition-type slot)))
71     `(,(slot-definition-name slot) ,(slot-definition-initform slot)
72       ,@(unless (eq type t) `(:type ,type)))))
73
74 (defmethod shared-initialize :after
75       ((class structure-class)
76        slot-names
77        &key (direct-superclasses nil direct-superclasses-p)
78             (direct-slots nil direct-slots-p)
79             direct-default-initargs
80             (predicate-name   nil predicate-name-p))
81   (declare (ignore slot-names direct-default-initargs))
82   (let* ((name (class-name class))
83          (from-defclass-p (slot-value class 'from-defclass-p))
84          (defstruct-form (defstruct-form name))
85          (conc-name
86            (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
87                (slot-value class 'defstruct-conc-name)
88                (format nil "~S structure class " name)))
89          (defstruct-predicate
90            (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
91          (pred-name  ;; Predicate name for class
92            (or (if predicate-name-p (car predicate-name))
93                (if defstruct-form defstruct-predicate)
94                (slot-value class 'predicate-name)
95                (make-class-predicate-name name)))
96          (constructor
97            (or (if defstruct-form (defstruct-form-constructor defstruct-form))
98                (slot-value class 'defstruct-constructor)
99                (if from-defclass-p
100                    (list (intern (format nil "~Aconstructor" conc-name)
101                                  (symbol-package name))
102                          ())))))
103     (declare (type symbol       name defstruct-predicate pred-name)
104              (type boolean       from-defclass-p)
105              (type simple-string conc-name))
106     (if direct-superclasses-p
107         (setf (slot-value class 'direct-superclasses)
108               (or direct-superclasses
109                   (setq direct-superclasses
110                         (if (eq name 'structure-object)
111                             nil
112                             (list *the-class-structure-object*)))))
113         (setq direct-superclasses (slot-value class 'direct-superclasses)))
114     (setq direct-slots
115           (if direct-slots-p
116               (setf (slot-value class 'direct-slots)
117                     (mapcar #'(lambda (pl)
118                                 (apply #'make-direct-slotd class
119                                         :conc-name conc-name pl))
120                             direct-slots))
121               (slot-value class 'direct-slots)))
122     (when from-defclass-p
123       (do-defstruct-from-defclass
124         class direct-superclasses direct-slots conc-name pred-name constructor))
125     (compile-structure-class-internals
126         class direct-slots conc-name pred-name constructor)
127     (setf (slot-value class 'predicate-name) pred-name)
128     (setf (slot-value class 'defstruct-conc-name) conc-name)
129     (unless (extract-required-parameters (second constructor))
130       (setf (slot-value class 'defstruct-constructor) (car constructor)))
131     (when (and defstruct-predicate (not from-defclass-p))
132       (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
133     (unless (or from-defclass-p (slot-value class 'documentation))
134       (setf (slot-value class 'documentation)
135             (format nil "~S structure class made from Defstruct" name)))
136     (setf (find-class name) class)
137     (update-structure-class class direct-superclasses direct-slots)))
138
139 (defun update-structure-class (class direct-superclasses direct-slots)
140   (add-direct-subclasses class direct-superclasses)
141   (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
142   (let* ((eslotds (compute-slots class))
143          (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
144     (setf (slot-value class 'slots) eslotds)
145     (setf (slot-value class 'internal-slotds) internal-slotds)
146     (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
147   (unless (slot-value class 'wrapper)
148     (setf (slot-value class 'finalized-p) T)
149     (setf (slot-value class 'wrapper) (make-wrapper class)))
150   (unless (slot-boundp class 'prototype)
151     (setf (slot-value class 'prototype) nil))
152   (setf (slot-value class 'default-initargs) nil)
153   (add-slot-accessors class direct-slots))
154
155 (defmethod do-defstruct-from-defclass ((class structure-class)
156                                        direct-superclasses direct-slots
157                                        conc-name predicate constructor)
158   (declare (type simple-string conc-name))
159   (let* ((name (class-name class))
160          (original-defstruct-form
161           `(original-defstruct
162               (,name
163                  ,@(when direct-superclasses
164                    `((:include ,(class-name (car direct-superclasses)))))
165                  (:print-function print-std-instance)
166                  (:predicate ,predicate)
167                  (:conc-name ,(intern conc-name (symbol-package name)))
168                  (:constructor ,@constructor))
169             ,@(mapcar #'slot-definition-defstruct-slot-description
170                       direct-slots))))
171     (eval original-defstruct-form)
172     (store-defstruct-form (cdr original-defstruct-form))))
173
174 (defmethod compile-structure-class-internals ((class structure-class)
175                                               direct-slots conc-name
176                                               predicate-name constructor)
177   (declare (type simple-string conc-name))
178   (let* ((name    (class-name class))
179          (package (symbol-package name))
180          (direct-slots-needing-internals
181            (if (slot-value class 'from-defclass-p)
182                direct-slots
183                (remove-if #'slot-definition-internal-reader-function
184                           direct-slots)))
185          (reader-names
186            (mapcar #'(lambda (slotd)
187                        (intern (format nil "~A~A reader" conc-name
188                                        (slot-definition-name slotd))
189                                 package))
190                    direct-slots-needing-internals))
191          (writer-names
192            (mapcar #'(lambda (slotd)
193                        (intern (format nil "~A~A writer" conc-name
194                                        (slot-definition-name slotd))
195                                package))
196                    direct-slots-needing-internals))
197          (defstruct-accessor-names
198            (mapcar #'slot-definition-defstruct-accessor-symbol
199                    direct-slots-needing-internals))
200          (readers-init
201            (mapcar #'(lambda (defstruct-accessor reader-name)
202                        `(progn
203                           (force-compile ',defstruct-accessor)
204                           (defun ,reader-name (obj)
205                             (declare (type ,name obj) #.*optimize-speed*)
206                             (,defstruct-accessor obj))
207                           (force-compile ',reader-name)))
208                    defstruct-accessor-names reader-names))
209          (writers-init
210            (mapcar #'(lambda (defstruct-accessor writer-name)
211                        `(progn
212                           (force-compile ',defstruct-accessor)
213                           (defun ,writer-name (nv obj)
214                             (declare (type ,name obj) #.*optimize-speed*)
215                             (setf (,defstruct-accessor obj) nv))
216                           (force-compile ',writer-name)))
217                    defstruct-accessor-names writer-names))
218          (defstruct-extras-form
219            `(progn
220               ,@(when (car constructor)
221                   `((force-compile ',(car constructor))))
222               ,@(when (fboundp predicate-name)
223                   `((force-compile ',predicate-name)))
224               ,@readers-init
225               ,@writers-init)))
226     (declare (type package package))
227     (eval defstruct-extras-form)
228     (mapc #'(lambda (dslotd reader-name writer-name)
229               (setf (slot-value dslotd 'internal-reader-function)
230                     (gdefinition reader-name))
231               (setf (slot-value dslotd 'internal-writer-function)
232                     (gdefinition writer-name)))
233           direct-slots-needing-internals reader-names writer-names)))
234
235 (defmethod reinitialize-instance :after ((class structure-class)
236                                          &rest initargs
237                                          &key)
238   (map-dependents class
239                   #'(lambda (dependent)
240                       (apply #'update-dependent class dependent initargs))))
241
242 (defmethod direct-slot-definition-class ((class structure-class) initargs)
243   (declare (ignore initargs))
244   (find-class 'structure-direct-slot-definition))
245
246 (defmethod effective-slot-definition-class ((class structure-class) initargs)
247   (declare (ignore initargs))
248   (find-class 'structure-effective-slot-definition))
249
250 (defmethod finalize-inheritance ((class structure-class))
251   nil) ; always finalized
252
253 (defmethod compute-slots ((class structure-class))
254   (mapcan #'(lambda (superclass)
255               (mapcar #'(lambda (dslotd)
256                           (compute-effective-slot-definition
257                              class (slot-definition-name dslotd) (list dslotd)))
258                       (class-direct-slots superclass)))
259           (reverse (slot-value class 'class-precedence-list))))
260
261 (defmethod compute-slots :around ((class structure-class))
262   (let ((eslotds (call-next-method)))
263     (mapc #'initialize-internal-slot-functions eslotds)
264     eslotds))
265
266 (defmethod compute-effective-slot-definition ((class structure-class)
267                                               name dslotds)
268   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
269          (class (effective-slot-definition-class class initargs))
270          (slot-definition (apply #'make-instance class initargs))
271          (internal-slotd
272            (make-internal-slotd
273              :name name
274              :slot-definition slot-definition
275              :initargs  (slot-definition-initargs     slot-definition)
276              :initfunction    (slot-definition-initfunction slot-definition))))
277     (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
278     slot-definition))
279
280 (defmethod compute-effective-slot-definition-initargs :around
281     ((class structure-class) direct-slotds)
282   (let ((slotd (car direct-slotds)))
283     (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
284            :internal-reader-function (slot-definition-internal-reader-function slotd)
285            :internal-writer-function (slot-definition-internal-writer-function slotd)
286            (call-next-method))))
287
288 (defmethod make-optimized-reader-method-function ((class structure-class)
289                                                   generic-function
290                                                   reader-method-prototype
291                                                   slot-name)
292   (declare (ignore generic-function reader-method-prototype))
293   (make-structure-instance-reader-method-function slot-name))
294
295 (defmethod make-optimized-writer-method-function ((class structure-class)
296                                                   generic-function
297                                                   writer-method-prototype
298                                                   slot-name)
299   (declare (ignore generic-function writer-method-prototype))
300   (make-structure-instance-writer-method-function slot-name))
301
302 (defmethod make-optimized-boundp-method-function ((class structure-class)
303                                                   generic-function
304                                                   boundp-method-prototype
305                                                   slot-name)
306   (declare (ignore generic-function boundp-method-prototype))
307   (make-structure-instance-boundp-method-function slot-name))
308
309 (defun make-structure-instance-reader-method-function (slot-name)
310   (declare #.*optimize-speed*)
311   #'(lambda (instance)
312       (structure-instance-slot-value instance slot-name)))
313
314 (defun make-structure-instance-writer-method-function (slot-name)
315   (declare #.*optimize-speed*)
316   #'(lambda (nv instance)
317       (setf (structure-instance-slot-value instance slot-name) nv)))
318
319 (defun make-structure-instance-boundp-method-function (slot-name)
320   (declare #.*optimize-speed*)
321   #'(lambda (instance)
322       (structure-instance-slot-boundp instance slot-name)))
323
324 (defmethod wrapper-fetcher ((class structure-class))
325   'wrapper-for-structure)
326
327 (defmethod slots-fetcher ((class structure-class))
328   nil)