1.0.5.50: some compare-and-swap changes
[sbcl.git] / src / pcl / defclass.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 ;;;; DEFCLASS macro and close personal friends
27
28 ;;; state for the current DEFCLASS expansion
29 (defvar *initfunctions-for-this-defclass*)
30 (defvar *readers-for-this-defclass*)
31 (defvar *writers-for-this-defclass*)
32 (defvar *slot-names-for-this-defclass*)
33
34 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
35 ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
36 ;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition
37 ;;; which simply collects all class definitions up, when the metabraid
38 ;;; is initialized it is done from those class definitions.
39 ;;;
40 ;;; After the metabraid has been setup, and the protocol for defining
41 ;;; classes has been defined, the real definition of LOAD-DEFCLASS is
42 ;;; installed by the file std-class.lisp
43 (defmacro defclass (&environment env name direct-superclasses direct-slots &rest options)
44   (let (*initfunctions-for-this-defclass*
45         *readers-for-this-defclass* ;Truly a crock, but we got
46         *writers-for-this-defclass* ;to have it to live nicely.
47         *slot-names-for-this-defclass*)
48     ;; FIXME: It would be nice to collect all errors from the
49     ;; expansion of a defclass and signal them in a single go.
50     (multiple-value-bind (metaclass canonical-options)
51         (canonize-defclass-options name options)
52     (let ((canonical-slots (canonize-defclass-slots name direct-slots env))
53           ;; DEFSTRUCT-P should be true if the class is defined
54           ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
55           ;; is compiled for the class.
56           (defstruct-p (and (eq *boot-state* 'complete)
57                             (let ((mclass (find-class metaclass nil)))
58                               (and mclass
59                                    (*subtypep
60                                     mclass
61                                     *the-class-structure-class*))))))
62       (let* ((defclass-form
63               `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
64                  (load-defclass ',name
65                                 ',metaclass
66                                 ',direct-superclasses
67                                 (list ,@canonical-slots)
68                                 (list ,@(apply #'append
69                                                (when defstruct-p
70                                                  '(:from-defclass-p t))
71                                                 canonical-options))
72                                 ',*readers-for-this-defclass*
73                                 ',*writers-for-this-defclass*
74                                 ',*slot-names-for-this-defclass*
75                                 (sb-c:source-location)
76                                 ',(safe-code-p env)))))
77         (if defstruct-p
78             (progn
79               ;; FIXME: (YUK!) Why do we do this? Because in order
80               ;; to make the defstruct form, we need to know what
81               ;; the accessors for the slots are, so we need already
82               ;; to have hooked into the CLOS machinery.
83               ;;
84               ;; There may be a better way to do this: it would
85               ;; involve knowing enough about PCL to ask "what will
86               ;; my slot names and accessors be"; failing this, we
87               ;; currently just evaluate the whole kaboodle, and
88               ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07
89               (eval defclass-form)
90               (let* ((include (or (and direct-superclasses
91                                        (find-class (car direct-superclasses) nil))
92                                   (and (not (eq name 'structure-object))
93                                        *the-class-structure-object*)))
94                      (defstruct-form (make-structure-class-defstruct-form
95                                       name (class-direct-slots (find-class name))
96                                       include)))
97                 `(progn
98                    (eval-when (:compile-toplevel :load-toplevel :execute)
99                      ,defstruct-form) ; really compile the defstruct-form
100                    (eval-when (:compile-toplevel :load-toplevel :execute)
101                      ,defclass-form))))
102             `(progn
103                ;; By telling the type system at compile time about
104                ;; the existence of a class named NAME, we can avoid
105                ;; various bogus warnings about "type isn't defined yet"
106                ;; for code elsewhere in the same file which uses
107                ;; the name of the type.
108                ;;
109                ;; We only need to do this at compile time, because
110                ;; at load and execute time we write the actual
111                ;; full-blown class, so the "a class of this name is
112                ;; coming" note we write here would be irrelevant.
113                (eval-when (:compile-toplevel)
114                  (%compiler-defclass ',name
115                                      ',*readers-for-this-defclass*
116                                      ',*writers-for-this-defclass*
117                                      ',*slot-names-for-this-defclass*))
118                (eval-when (:load-toplevel :execute)
119                  ,defclass-form))))))))
120
121 (defun canonize-defclass-options (class-name options)
122   (maplist (lambda (sublist)
123              (let ((option-name (first (pop sublist))))
124                (when (member option-name sublist :key #'first)
125                  (error 'simple-program-error
126                         :format-control "Multiple ~S options in DEFCLASS ~S."
127                         :format-arguments (list option-name class-name)))))
128            options)
129   (let (metaclass
130         default-initargs
131         documentation
132         canonized-options)
133       (dolist (option options)
134         (unless (listp option)
135           (error "~S is not a legal defclass option." option))
136         (case (first option)
137           (:metaclass
138            (let ((maybe-metaclass (second option)))
139              (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass))
140                (error 'simple-program-error
141                       :format-control "~@<The value of the :metaclass option (~S) ~
142                          is not a legal class name.~:@>"
143                       :format-arguments (list maybe-metaclass)))
144              (setf metaclass maybe-metaclass)))
145           (:default-initargs
146            (let (initargs arg-names)
147              (doplist (key val) (cdr option)
148                (when (member key arg-names)
149                  (error 'simple-program-error
150                         :format-control "~@<Duplicate initialization argument ~
151                                            name ~S in :DEFAULT-INITARGS of ~
152                                            DEFCLASS ~S.~:>"
153                         :format-arguments (list key class-name)))
154                (push key arg-names)
155                (push ``(,',key ,',val ,,(make-initfunction val)) initargs))
156              (setf default-initargs t)
157              (push `(:direct-default-initargs (list ,@(nreverse initargs)))
158                    canonized-options)))
159           (:documentation
160            (unless (stringp (second option))
161              (error "~S is not a legal :documentation value" (second option)))
162            (setf documentation t)
163            (push `(:documentation ,(second option)) canonized-options))
164           (otherwise
165            (push `(',(car option) ',(cdr option)) canonized-options))))
166       (values (or metaclass 'standard-class) (nreverse canonized-options))))
167
168 (defun canonize-defclass-slots (class-name slots env)
169   (let (canonized-specs)
170     (dolist (spec slots)
171       (when (atom spec)
172         (setf spec (list spec)))
173       (when (and (cdr spec) (null (cddr spec)))
174         (error 'simple-program-error
175                :format-control "~@<in DEFCLASS ~S, the slot specification ~S ~
176                                 is invalid; the probable intended meaning may ~
177                                 be achieved by specifiying ~S instead.~:>"
178                :format-arguments (list class-name spec
179                                        `(,(car spec) :initform ,(cadr spec)))))
180       (let* ((name (car spec))
181              (plist (cdr spec))
182              (readers ())
183              (writers ())
184              (initargs ())
185              (others ())
186              (unsupplied (list nil))
187              (type t)
188              (initform unsupplied))
189         (check-slot-name-for-defclass name class-name env)
190         (push name *slot-names-for-this-defclass*)
191         (flet ((note-reader (x)
192                  (unless (symbolp x)
193                    (error 'simple-program-error
194                           :format-control "Slot reader name ~S for slot ~S in ~
195                                            DEFCLASS ~S is not a symbol."
196                           :format-arguments (list x name class-name)))
197                  (push x readers)
198                  (push x *readers-for-this-defclass*))
199                (note-writer (x)
200                  (push x writers)
201                  (push x *writers-for-this-defclass*)))
202           (doplist (key val) plist
203             (case key
204               (:accessor (note-reader val) (note-writer `(setf ,val)))
205               (:reader   (note-reader val))
206               (:writer   (note-writer val))
207               (:initarg
208                (unless (symbolp val)
209                  (error 'simple-program-error
210                         :format-control "Slot initarg name ~S for slot ~S in ~
211                                          DEFCLASS ~S is not a symbol."
212                         :format-arguments (list val name class-name)))
213                (push val initargs))
214               (otherwise
215                (when (member key '(:initform :allocation :type :documentation))
216                  (when (eq key :initform)
217                    (setf initform val))
218                  (when (eq key :type)
219                    (setf type val))
220                  (when (get-properties others (list key))
221                    (error 'simple-program-error
222                           :format-control "Duplicate slot option ~S for slot ~
223                                            ~S in DEFCLASS ~S."
224                           :format-arguments (list key name class-name))))
225                ;; For non-standard options multiple entries go in a list
226                (push val (getf others key))))))
227         ;; Unwrap singleton lists (AMOP 5.4.2)
228         (do ((head others (cddr head)))
229             ((null head))
230           (unless (cdr (second head))
231             (setf (second head) (car (second head)))))
232         (let* ((type-check-function
233                 (if (eq type t)
234                     nil
235                     `('type-check-function (lambda (value)
236                                              (declare (type ,type value)
237                                                       (optimize (sb-c:store-coverage-data 0)))
238                                              value))))
239                (canon `(:name ',name :readers ',readers :writers ',writers
240                               :initargs ',initargs
241                               ,@type-check-function
242                               ',others)))
243           (push (if (eq initform unsupplied)
244                     `(list* ,@canon)
245                     `(list* :initfunction ,(make-initfunction initform)
246                             ,@canon))
247                 canonized-specs))))
248     (nreverse canonized-specs)))
249
250
251 (defun check-slot-name-for-defclass (name class-name env)
252   (flet ((slot-name-illegal (reason)
253            (error 'simple-program-error
254                   :format-control
255                   (format nil "~~@<In DEFCLASS ~~S, the slot name ~~S ~
256                                is ~A.~~@:>" reason)
257                   :format-arguments (list class-name name))))
258     (cond ((not (symbolp name))
259            (slot-name-illegal "not a symbol"))
260           ((keywordp name)
261            (slot-name-illegal "a keyword"))
262           ((constantp name env)
263            (slot-name-illegal "a constant"))
264           ((member name *slot-names-for-this-defclass*)
265            (error 'simple-program-error
266                   :format-control "Multiple slots named ~S in DEFCLASS ~S."
267                   :format-arguments (list name class-name))))))
268
269 (defun make-initfunction (initform)
270   (cond ((or (eq initform t)
271              (equal initform ''t))
272          '(function constantly-t))
273         ((or (eq initform nil)
274              (equal initform ''nil))
275          '(function constantly-nil))
276         ((or (eql initform 0)
277              (equal initform ''0))
278          '(function constantly-0))
279         (t
280          (let ((entry (assoc initform *initfunctions-for-this-defclass*
281                              :test #'equal)))
282            (unless entry
283              (setq entry (list initform
284                                (gensym)
285                                `(function (lambda ()
286                                   (declare (optimize
287                                             (sb-c:store-coverage-data 0)))
288                                   ,initform))))
289              (push entry *initfunctions-for-this-defclass*))
290            (cadr entry)))))
291
292 (defun %compiler-defclass (name readers writers slots)
293   ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
294   ;; "appears as a top level form, the compiler must make the class
295   ;; name be recognized as a valid type name in subsequent
296   ;; declarations (as for deftype) and be recognized as a valid class
297   ;; name for defmethod parameter specializers and for use as the
298   ;; :metaclass option of a subsequent defclass."
299   (preinform-compiler-about-class-type name)
300   (preinform-compiler-about-accessors readers writers slots))
301
302 (defun preinform-compiler-about-class-type (name)
303   ;; Unless the type system already has an actual type attached to
304   ;; NAME (in which case (1) writing a placeholder value over that
305   ;; actual type as a compile-time side-effect would probably be a bad
306   ;; idea and (2) anyway we don't need to modify it in order to make
307   ;; NAME be recognized as a valid type name)
308   (unless (info :type :kind name)
309     ;; Tell the compiler to expect a class with the given NAME, by
310     ;; writing a kind of minimal placeholder type information. This
311     ;; placeholder will be overwritten later when the class is defined.
312     (setf (info :type :kind name) :forthcoming-defclass-type))
313   (values))
314
315 (defun preinform-compiler-about-accessors (readers writers slots)
316   (flet ((inform (name type)
317            ;; FIXME: This matches what PROCLAIM FTYPE does, except
318            ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should
319            ;; probably be factored into a common function -- eg.
320            ;; (%proclaim-ftype name declared-or-defined).
321            (when (eq (info :function :where-from name) :assumed)
322              (proclaim-as-fun-name name)
323              (note-name-defined name :function)
324              (setf (info :function :where-from name) :defined
325                    (info :function :type name) type))))
326     (let ((rtype (specifier-type '(function (t) t)))
327           (wtype (specifier-type '(function (t t) t))))
328       (dolist (reader readers)
329         (inform reader rtype))
330       (dolist (writer writers)
331         (inform writer wtype))
332       (dolist (slot slots)
333         (inform (slot-reader-name slot) rtype)
334         (inform (slot-boundp-name slot) rtype)
335         (inform (slot-writer-name slot) wtype)))))
336 \f
337 ;;; This is the early definition of LOAD-DEFCLASS. It just collects up
338 ;;; all the class definitions in a list. Later, in braid1.lisp, these
339 ;;; are actually defined.
340
341 ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
342 (defparameter *early-class-definitions* ())
343
344 (defun early-class-definition (class-name)
345   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
346       (error "~S is not a class in *early-class-definitions*." class-name)))
347
348 (defun make-early-class-definition
349        (name source-location metaclass
350         superclass-names canonical-slots other-initargs)
351   (list 'early-class-definition
352         name source-location metaclass
353         superclass-names canonical-slots other-initargs))
354
355 (defun ecd-class-name        (ecd) (nth 1 ecd))
356 (defun ecd-source-location   (ecd) (nth 2 ecd))
357 (defun ecd-metaclass         (ecd) (nth 3 ecd))
358 (defun ecd-superclass-names  (ecd) (nth 4 ecd))
359 (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
360 (defun ecd-other-initargs    (ecd) (nth 6 ecd))
361
362 (defvar *early-class-slots* nil)
363
364 (defun canonical-slot-name (canonical-slot)
365   (getf canonical-slot :name))
366
367 (defun early-class-slots (class-name)
368   (cdr (or (assoc class-name *early-class-slots*)
369            (let ((a (cons class-name
370                           (mapcar #'canonical-slot-name
371                                   (early-collect-inheritance class-name)))))
372              (push a *early-class-slots*)
373              a))))
374
375 (defun early-class-size (class-name)
376   (length (early-class-slots class-name)))
377
378 (defun early-collect-inheritance (class-name)
379   ;;(declare (values slots cpl default-initargs direct-subclasses))
380   (let ((cpl (early-collect-cpl class-name)))
381     (values (early-collect-slots cpl)
382             cpl
383             (early-collect-default-initargs cpl)
384             (let (collect)
385               (dolist (definition *early-class-definitions*)
386                 (when (memq class-name (ecd-superclass-names definition))
387                   (push (ecd-class-name definition) collect)))
388               (nreverse collect)))))
389
390 (defun early-collect-slots (cpl)
391   (let* ((definitions (mapcar #'early-class-definition cpl))
392          (super-slots (mapcar #'ecd-canonical-slots definitions))
393          (slots (apply #'append (reverse super-slots))))
394     (dolist (s1 slots)
395       (let ((name1 (canonical-slot-name s1)))
396         (dolist (s2 (cdr (memq s1 slots)))
397           (when (eq name1 (canonical-slot-name s2))
398             (error "More than one early class defines a slot with the~%~
399                     name ~S. This can't work because the bootstrap~%~
400                     object system doesn't know how to compute effective~%~
401                     slots."
402                    name1)))))
403     slots))
404
405 (defun early-collect-cpl (class-name)
406   (labels ((walk (c)
407              (let* ((definition (early-class-definition c))
408                     (supers (ecd-superclass-names definition)))
409                (cons c
410                      (apply #'append (mapcar #'early-collect-cpl supers))))))
411     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
412
413 (defun early-collect-default-initargs (cpl)
414   (let ((default-initargs ()))
415     (dolist (class-name cpl)
416       (let* ((definition (early-class-definition class-name))
417              (others (ecd-other-initargs definition)))
418         (loop (when (null others) (return nil))
419               (let ((initarg (pop others)))
420                 (unless (eq initarg :direct-default-initargs)
421                  (error "~@<The defclass option ~S is not supported by ~
422                         the bootstrap object system.~:@>"
423                         initarg)))
424               (setq default-initargs
425                     (nconc default-initargs (reverse (pop others)))))))
426     (reverse default-initargs)))
427
428 (defun !bootstrap-slot-index (class-name slot-name)
429   (or (position slot-name (early-class-slots class-name))
430       (error "~S not found" slot-name)))
431
432 ;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
433 ;;; change the values of slots during bootstrapping. During
434 ;;; bootstrapping, there are only two kinds of objects whose slots we
435 ;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
436 ;;; to these functions tells whether the object is a CLASS or a
437 ;;; SLOT-DEFINITION.
438 ;;;
439 ;;; Note that the way this works it stores the slot in the same place
440 ;;; in memory that the full object system will expect to find it
441 ;;; later. This is critical to the bootstrapping process, the whole
442 ;;; changeover to the full object system is predicated on this.
443 ;;;
444 ;;; One important point is that the layout of standard classes and
445 ;;; standard slots must be computed the same way in this file as it is
446 ;;; by the full object system later.
447 (defmacro !bootstrap-get-slot (type object slot-name)
448   `(clos-slots-ref (get-slots ,object)
449                    (!bootstrap-slot-index ,type ,slot-name)))
450 (defun !bootstrap-set-slot (type object slot-name new-value)
451   (setf (!bootstrap-get-slot type object slot-name) new-value))
452
453 (defun early-class-name (class)
454   (!bootstrap-get-slot 'class class 'name))
455
456 (defun early-class-precedence-list (class)
457   (!bootstrap-get-slot 'pcl-class class '%class-precedence-list))
458
459 (defun early-class-name-of (instance)
460   (early-class-name (class-of instance)))
461
462 (defun early-class-slotds (class)
463   (!bootstrap-get-slot 'slot-class class 'slots))
464
465 (defun early-slot-definition-name (slotd)
466   (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
467
468 (defun early-slot-definition-location (slotd)
469   (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
470
471 (defun early-accessor-method-slot-name (method)
472   (!bootstrap-get-slot 'standard-accessor-method method 'slot-name))
473
474 (unless (fboundp 'class-name-of)
475   (setf (symbol-function 'class-name-of)
476         (symbol-function 'early-class-name-of)))
477 (unintern 'early-class-name-of)
478
479 (defun early-class-direct-subclasses (class)
480   (!bootstrap-get-slot 'class class 'direct-subclasses))
481
482 (declaim (notinline load-defclass))
483 (defun load-defclass (name metaclass supers canonical-slots canonical-options
484                       readers writers slot-names source-location safe-p)
485   ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since
486   ;; during the bootstrap we won't have (SAFETY 3).
487   (declare (ignore safe-p))
488   (%compiler-defclass name readers writers slot-names)
489   (setq supers  (copy-tree supers)
490         canonical-slots   (copy-tree canonical-slots)
491         canonical-options (copy-tree canonical-options))
492   (let ((ecd
493          (make-early-class-definition name
494                                       source-location
495                                       metaclass
496                                       supers
497                                       canonical-slots
498                                       canonical-options))
499         (existing
500          (find name *early-class-definitions* :key #'ecd-class-name)))
501     (setq *early-class-definitions*
502           (cons ecd (remove existing *early-class-definitions*)))
503     ecd))