clos.lisp 203 KB
Newer Older
1
2
3
;;; clos.lisp
;;;
;;; Copyright (C) 2003-2007 Peter Graves
4
;;; Copyright (C) 2010-2013 Mark Evenson
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

;;; Originally based on Closette.
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
;;; Closette Version 1.0 (February 10, 1991)
;;;
;;; Copyright (c) 1990, 1991 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Closette is an implementation of a subset of CLOS with a metaobject
;;; protocol as described in "The Art of The Metaobject Protocol",
;;; MIT Press, 1991.

(in-package #:mop)

55
56
57
(export '(%defgeneric canonicalize-direct-superclasses))


58
59
60
61
62
63
64
65
66
67
68
69
70
;;
;;
;;
;; In order to bootstrap CLOS, first implement the required API as
;; normal functions which only apply to the "root" metaclass
;; STANDARD-CLASS.
;;
;; After putting the normal functions in place, the building blocks
;; are in place to gradually swap the normal functions with
;; generic functions and methods.
;;
;; Some functionality implemented in the temporary regular functions
;; needs to be available later as a method definition to be dispatched
71
72
73
74
75
76
77
;; to for the standard case, e.g. with arguments of type STANDARD-CLASS
;; or STANDARD-GENERIC-FUNCTION.  To prevent repeated code, the
;; functions are implemented in functions by the same name as the API
;; functions, but with the STD- prefix.  These functions are sometimes
;; used in regular code as well, either in a "fast path" or to break a
;; circularity (e.g., within compute-discriminating-function when the
;; user adds a method to compute-discriminating-function).
78
79
80
81
82
83
84
85
86
87
;;
;; When hacking this file, note that some important parts are implemented
;; in the Java world. These Java bits can be found in the files
;;
;; * LispClass.java
;; * SlotClass.java
;; * StandardClass.java
;; * BuiltInClass.java
;; * StandardObject.java
;; * StandardObjectFunctions.java
88
;; * FuncallableStandardObject.java
89
90
91
;; * Layout.java
;;
;; In case of function names, those defined on the Java side can be
92
;; recognized by their prefixed percent (%) sign.
93
94
95
96
97
98
99
100
101
102
103
104
;;
;; The API functions need to be declaimed NOTINLINE explicitly, because
;; that prevents inlining in the current FASL (which is allowed by the
;; CLHS without the declaration); this is a hard requirement to in order
;; to be able to swap the symbol's function slot with a generic function
;; later on - with it actually being used.
;;
;;
;;
;; ### Note that the "declares all API functions as regular functions"
;; isn't true when I write the above, but it's definitely the target.
;;
105
106
107
108
109
110
111
112
;; A note about AMOP: the first chapters (and the sample Closette
;; implementation) of the book sometimes deviate from the specification.
;; For example, in the examples slot-value-using-class has the slot name
;; as third argument where in the specification it is the effective slot
;; definition.  When in doubt, we aim to follow the specification, the
;; MOP test suite at http://common-lisp.net/project/closer/features.html
;; and the behavior of other CL implementations in preference to
;; chapters 1-4 and appendix D.
113

114
(defconstant +the-standard-class+ (find-class 'standard-class))
115
116
(defconstant +the-funcallable-standard-class+
  (find-class 'funcallable-standard-class))
117
(defconstant +the-standard-object-class+ (find-class 'standard-object))
118
119
(defconstant +the-funcallable-standard-object-class+
  (find-class 'funcallable-standard-object))
120
121
(defconstant +the-standard-method-class+ (find-class 'standard-method))
(defconstant +the-T-class+ (find-class 'T))
122
123
124
(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
(defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition))
125

126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;; Don't use DEFVAR, because that disallows loading clos.lisp
;; after compiling it: the binding won't get assigned to T anymore
(defparameter *clos-booting* t)

(defmacro define-class->%class-forwarder (name)
  (let* (($name (if (consp name) (cadr name) name))
         (%name (intern (concatenate 'string
                                     "%"
                                     (if (consp name)
                                         (symbol-name 'set-) "")
                                     (symbol-name $name))
                        (symbol-package $name))))
    `(progn
       (declaim (notinline ,name))
       (defun ,name (&rest args)
         (apply #',%name args)))))

143
144
145
146
;;
;;  DEFINE PLACE HOLDER FUNCTIONS
;;

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(define-class->%class-forwarder class-name)
(define-class->%class-forwarder (setf class-name))
(define-class->%class-forwarder class-slots)
(define-class->%class-forwarder (setf class-slots))
(define-class->%class-forwarder class-direct-slots)
(define-class->%class-forwarder (setf class-direct-slots))
(define-class->%class-forwarder class-layout)
(define-class->%class-forwarder (setf class-layout))
(define-class->%class-forwarder class-direct-superclasses)
(define-class->%class-forwarder (setf class-direct-superclasses))
(define-class->%class-forwarder class-direct-subclasses)
(define-class->%class-forwarder (setf class-direct-subclasses))
(define-class->%class-forwarder class-direct-methods)
(define-class->%class-forwarder (setf class-direct-methods))
(define-class->%class-forwarder class-precedence-list)
(define-class->%class-forwarder (setf class-precedence-list))
(define-class->%class-forwarder class-finalized-p)
(define-class->%class-forwarder (setf class-finalized-p))
(define-class->%class-forwarder class-default-initargs)
(define-class->%class-forwarder (setf class-default-initargs))
(define-class->%class-forwarder class-direct-default-initargs)
(define-class->%class-forwarder (setf class-direct-default-initargs))

170
171
172
173
174
175
176
177
(declaim (notinline add-direct-subclass remove-direct-subclass))
(defun add-direct-subclass (superclass subclass)
  (setf (class-direct-subclasses superclass)
        (adjoin subclass (class-direct-subclasses superclass))))
(defun remove-direct-subclass (superclass subclass)
  (setf (class-direct-subclasses superclass)
        (remove subclass (class-direct-subclasses superclass))))

178
179
180
(defun fixup-standard-class-hierarchy ()
  ;; Make the result of class-direct-subclasses for the pre-built
  ;; classes agree with AMOP Table 5.1 (pg. 141).  This could be done in
181
182
  ;; StandardClass.java where these classes are defined, but it's less
  ;; painful to do it Lisp-side.
183
184
185
186
187
188
189
190
191
  (flet ((add-subclasses (class subclasses)
           (when (atom subclasses) (setf subclasses (list subclasses)))
           (setf (class-direct-subclasses (find-class class))
                 (union (class-direct-subclasses (find-class class))
                        (mapcar #'find-class subclasses)))))
    (add-subclasses t 'standard-object)
    (add-subclasses 'function 'funcallable-standard-object)
    (add-subclasses 'standard-object '(funcallable-standard-object metaobject))
    (add-subclasses 'metaobject
192
                    '(generic-function method slot-definition specializer))
193
    (add-subclasses 'specializer '(class))
194
195
196
197
198
199
200
201
202
203
204
205
    (add-subclasses 'funcallable-standard-object 'generic-function)
    (add-subclasses 'method 'standard-method)
    (add-subclasses 'slot-definition
                    '(direct-slot-definition effective-slot-definition
                      standard-slot-definition))
    (add-subclasses 'standard-slot-definition
                    '(standard-direct-slot-definition
                      standard-effective-slot-definition))
    (add-subclasses 'direct-slot-definition 'standard-direct-slot-definition)
    (add-subclasses 'effective-slot-definition
                    'standard-effective-slot-definition)
    (add-subclasses 'class
206
                    '(built-in-class standard-class funcallable-standard-class))))
207
208
(fixup-standard-class-hierarchy)

209
210
211
212
213
(defun std-class-p (class)
  (let ((metaclass (class-of class)))
    (or (eq metaclass +the-standard-class+)
        (eq metaclass +the-funcallable-standard-class+))))

214
215
216
217
218
(defun no-applicable-method (generic-function &rest args)
  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
         generic-function
         args))

219
(defun function-keywords (method)
220
  (std-function-keywords method))
221

222
223
224
225
226
(declaim (notinline map-dependents))
(defun map-dependents (metaobject function)
  ;; stub, will be redefined later
  (declare (ignore metaobject function))
  nil)
227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
(defmacro push-on-end (value location)
  `(setf ,location (nconc ,location (list ,value))))

;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
;;; which must be non-nil.

(defun (setf getf*) (new-value plist key)
  (block body
    (do ((x plist (cddr x)))
        ((null x))
      (when (eq (car x) key)
        (setf (car (cdr x)) new-value)
        (return-from body new-value)))
    (push-on-end key plist)
    (push-on-end new-value plist)
    new-value))

(defun mapappend (fun &rest args)
  (if (some #'null args)
      ()
      (append (apply fun (mapcar #'car args))
              (apply #'mapappend fun (mapcar #'cdr args)))))

(defun mapplist (fun x)
  (if (null x)
      ()
      (cons (funcall fun (car x) (cadr x))
            (mapplist fun (cddr x)))))

257
258
(defsetf std-slot-value set-std-slot-value)

259
260
(defsetf std-instance-layout %set-std-instance-layout)
(defsetf standard-instance-access %set-standard-instance-access)
261
262
263
(defun funcallable-standard-instance-access (instance location)
  (standard-instance-access instance location))
(defsetf funcallable-standard-instance-access %set-standard-instance-access)
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

(defun (setf find-class) (new-value symbol &optional errorp environment)
  (declare (ignore errorp environment))
  (%set-find-class symbol new-value))

(defun canonicalize-direct-slots (direct-slots)
  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))

(defun canonicalize-direct-slot (spec)
  (if (symbolp spec)
      `(list :name ',spec)
      (let ((name (car spec))
            (initfunction nil)
            (initform nil)
            (initargs ())
            (type nil)
            (allocation nil)
            (documentation nil)
            (readers ())
            (writers ())
284
            (other-options ())
285
            (non-std-options ()))
286
287
288
289
290
291
292
293
        (do ((olist (cdr spec) (cddr olist)))
            ((null olist))
          (case (car olist)
            (:initform
             (when initform
               (error 'program-error
                      "duplicate slot option :INITFORM for slot named ~S"
                      name))
294
295
             (setq initfunction t)
             (setq initform (cadr olist)))
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
            (:initarg
             (push-on-end (cadr olist) initargs))
            (:allocation
             (when allocation
               (error 'program-error
                      "duplicate slot option :ALLOCATION for slot named ~S"
                      name))
             (setf allocation (cadr olist))
             (push-on-end (car olist) other-options)
             (push-on-end (cadr olist) other-options))
            (:type
             (when type
               (error 'program-error
                      "duplicate slot option :TYPE for slot named ~S"
                      name))
311
             (setf type (cadr olist)))
312
313
314
315
316
            (:documentation
             (when documentation
               (error 'program-error
                      "duplicate slot option :DOCUMENTATION for slot named ~S"
                      name))
317
             (setf documentation (cadr olist)))
318
319
320
321
322
323
324
325
326
327
328
            (:reader
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) readers))
            (:writer
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) writers))
            (:accessor
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) readers)
             (push-on-end `(setf ,(cadr olist)) writers))
            (t
329
             (push-on-end (cadr olist) (getf non-std-options (car olist))))))
330
331
332
        `(list
          :name ',name
          ,@(when initfunction
333
334
335
336
337
338
339
340
341
342
              `(:initform ',initform
                :initfunction ,(if (eq allocation :class)
                                   ;; CLHS specifies the initform for a
                                   ;; class allocation level slot needs
                                   ;; to be evaluated in the dynamic
                                   ;; extent of the DEFCLASS form
                                   (let ((var (gensym)))
                                     `(let ((,var ,initform))
                                        (lambda () ,var)))
                                 `(lambda () ,initform))))
343
344
345
          ,@(when initargs `(:initargs ',initargs))
          ,@(when readers `(:readers ',readers))
          ,@(when writers `(:writers ',writers))
346
347
          ,@(when type `(:type ',type))
          ,@(when documentation `(:documentation ',documentation))
348
          ,@other-options
349
350
351
352
          ,@(mapcar #'(lambda (opt) (if (or (atom opt) (/= 1 (length opt)))
                                        `',opt
                                        `',(car opt)))
                    non-std-options)))))
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368

(defun maybe-note-name-defined (name)
  (when (fboundp 'note-name-defined)
    (note-name-defined name)))

(defun canonicalize-defclass-options (options)
  (mapappend #'canonicalize-defclass-option options))

(defun canonicalize-defclass-option (option)
  (case (car option)
    (:metaclass
     (list ':metaclass
           `(find-class ',(cadr option))))
    (:default-initargs
     (list
      ':direct-default-initargs
369
370
371
372
      `(list ,@(mapplist
                #'(lambda (key value)
                    `(list ',key ',value ,(make-initfunction value)))
                (cdr option)))))
373
374
    ((:documentation :report)
     (list (car option) `',(cadr option)))
375
    (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
376
377
378
379

(defun make-initfunction (initform)
  `(function (lambda () ,initform)))

380
(defun slot-definition-allocation (slot-definition)
381
  (std-slot-value slot-definition 'sys::allocation))
382

383
(declaim (notinline (setf slot-definition-allocation)))
384
(defun (setf slot-definition-allocation) (value slot-definition)
385
  (setf (std-slot-value slot-definition 'sys::allocation) value))
386

387
(defun slot-definition-initargs (slot-definition)
388
  (std-slot-value slot-definition 'sys::initargs))
389

390
(declaim (notinline (setf slot-definition-initargs)))
391
(defun (setf slot-definition-initargs) (value slot-definition)
392
  (setf (std-slot-value slot-definition 'sys::initargs) value))
393

394
(defun slot-definition-initform (slot-definition)
395
  (std-slot-value slot-definition 'sys::initform))
396

397
(declaim (notinline (setf slot-definition-initform)))
398
(defun (setf slot-definition-initform) (value slot-definition)
399
  (setf (std-slot-value slot-definition 'sys::initform) value))
400

401
(defun slot-definition-initfunction (slot-definition)
402
  (std-slot-value slot-definition 'sys::initfunction))
403

404
(declaim (notinline (setf slot-definition-initfunction)))
405
(defun (setf slot-definition-initfunction) (value slot-definition)
406
  (setf (std-slot-value slot-definition 'sys::initfunction) value))
407

408
(defun slot-definition-name (slot-definition)
409
  (std-slot-value slot-definition 'sys:name))
410

411
(declaim (notinline (setf slot-definition-name)))
412
(defun (setf slot-definition-name) (value slot-definition)
413
  (setf (std-slot-value slot-definition 'sys:name) value))
414

415
(defun slot-definition-readers (slot-definition)
416
  (std-slot-value slot-definition 'sys::readers))
417

418
(declaim (notinline (setf slot-definition-readers)))
419
(defun (setf slot-definition-readers) (value slot-definition)
420
  (setf (std-slot-value slot-definition 'sys::readers) value))
421
422

(defun slot-definition-writers (slot-definition)
423
  (std-slot-value slot-definition 'sys::writers))
424

425
(declaim (notinline (setf slot-definition-writers)))
426
(defun (setf slot-definition-writers) (value slot-definition)
427
  (setf (std-slot-value slot-definition 'sys::writers) value))
428
429

(defun slot-definition-allocation-class (slot-definition)
430
  (std-slot-value slot-definition 'sys::allocation-class))
431

432
(declaim (notinline (setf slot-definition-allocation-class)))
433
(defun (setf slot-definition-allocation-class) (value slot-definition)
434
  (setf (std-slot-value slot-definition 'sys::allocation-class) value))
435

436
(defun slot-definition-location (slot-definition)
437
  (std-slot-value slot-definition 'sys::location))
438
439
440

(declaim (notinline (setf slot-definition-location-class)))
(defun (setf slot-definition-location) (value slot-definition)
441
  (setf (std-slot-value slot-definition 'sys::location) value))
442

443
(defun slot-definition-type (slot-definition)
444
  (std-slot-value slot-definition 'sys::%type))
445
446
447

(declaim (notinline (setf slot-definition-type)))
(defun (setf slot-definition-type) (value slot-definition)
448
  (setf (std-slot-value slot-definition 'sys::%type) value))
449
450

(defun slot-definition-documentation (slot-definition)
451
  (std-slot-value slot-definition 'sys:%documentation))
452
453
454

(declaim (notinline (setf slot-definition-documentation)))
(defun (setf slot-definition-documentation) (value slot-definition)
455
  (setf (std-slot-value slot-definition 'sys:%documentation) value))
456

457
(defun init-slot-definition (slot &key name
458
459
460
461
462
463
464
465
466
                                    (initargs ())
                                    (initform nil)
                                    (initfunction nil)
                                    (readers ())
                                    (writers ())
                                    (allocation :instance)
                                    (allocation-class nil)
                                    (type t)
                                    (documentation nil))
467
468
469
470
  (setf (slot-definition-name slot) name)
  (setf (slot-definition-initargs slot) initargs)
  (setf (slot-definition-initform slot) initform)
  (setf (slot-definition-initfunction slot) initfunction)
471
472
  (setf (slot-definition-readers slot) readers)
  (setf (slot-definition-writers slot) writers)
473
  (setf (slot-definition-allocation slot) allocation)
474
  (setf (slot-definition-allocation-class slot) allocation-class)
475
476
  (setf (slot-definition-type slot) type)
  (setf (slot-definition-documentation slot) documentation)
477
478
  slot)

479
480
481
482
483
(declaim (notinline direct-slot-definition-class))
(defun direct-slot-definition-class (class &rest args)
  (declare (ignore class args))
  +the-standard-direct-slot-definition-class+)

484
(defun make-direct-slot-definition (class &rest args)
485
  (let ((slot-class (apply #'direct-slot-definition-class class args)))
486
    (if (eq slot-class +the-standard-direct-slot-definition-class+)
487
        (let ((slot (%make-slot-definition +the-standard-direct-slot-definition-class+)))
488
489
490
491
492
493
494
495
496
497
498
          (apply #'init-slot-definition slot :allocation-class class args)
          slot)
        (progn
          (let ((slot (apply #'make-instance slot-class :allocation-class class
                             args)))
            slot)))))

(declaim (notinline effective-slot-definition-class))
(defun effective-slot-definition-class (class &rest args)
  (declare (ignore class args))
  +the-standard-effective-slot-definition-class+)
499
500

(defun make-effective-slot-definition (class &rest args)
501
  (let ((slot-class (apply #'effective-slot-definition-class class args)))
502
    (if (eq slot-class +the-standard-effective-slot-definition-class+)
503
        (let ((slot (%make-slot-definition +the-standard-effective-slot-definition-class+)))
504
505
506
507
508
          (apply #'init-slot-definition slot args)
          slot)
        (progn
          (let ((slot (apply #'make-instance slot-class args)))
            slot)))))
509
510
511

;;; finalize-inheritance

512
513
514
515
516
(declaim (notinline compute-default-initargs))
(defun compute-default-initargs (class)
  (std-compute-default-initargs class))

(defun std-compute-default-initargs (class)
517
518
519
520
521
522
  (delete-duplicates
   (mapcan #'(lambda (c)
               (copy-list
                (class-direct-default-initargs c)))
           (class-precedence-list class))
   :key #'car :from-end t))
523

524
(defun std-finalize-inheritance (class)
525
526
527
528
  ;; In case the class is already finalized, return
  ;; immediately, as per AMOP.
  (when (class-finalized-p class)
    (return-from std-finalize-inheritance))
529
  (setf (class-precedence-list class)
530
531
532
533
        (funcall (if (std-class-p class)
                     #'std-compute-class-precedence-list
                     #'compute-class-precedence-list)
                 class))
534
  (setf (class-slots class)
535
        (funcall (if (std-class-p class)
536
                     #'std-compute-slots
537
                     #'compute-slots) class))
538
539
540
541
  (let ((old-layout (class-layout class))
        (length 0)
        (instance-slots '())
        (shared-slots '()))
542
    (dolist (slot (class-slots class))
543
      (case (slot-definition-allocation slot)
544
        (:instance
545
         (setf (slot-definition-location slot) length)
546
         (incf length)
547
         (push (slot-definition-name slot) instance-slots))
548
        (:class
549
         (unless (slot-definition-location slot)
550
           (let ((allocation-class (slot-definition-allocation-class slot)))
551
552
553
554
555
556
557
558
559
560
             (if (eq allocation-class class)
                 ;; We initialize class slots here so they can be
                 ;; accessed without creating a dummy instance.
                 (let ((initfunction (slot-definition-initfunction slot)))
                   (setf (slot-definition-location slot)
                         (cons (slot-definition-name slot)
                               (if initfunction
                                   (funcall initfunction)
                                   +slot-unbound+))))
                 (setf (slot-definition-location slot)
561
                       (slot-location allocation-class (slot-definition-name slot))))))
562
         (push (slot-definition-location slot) shared-slots))))
563
564
565
566
567
568
    (when old-layout
      ;; Redefined class: initialize added shared slots.
      (dolist (location shared-slots)
        (let* ((slot-name (car location))
               (old-location (layout-slot-location old-layout slot-name)))
          (unless old-location
569
            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
570
                   (initfunction (slot-definition-initfunction slot-definition)))
571
572
573
574
              (when initfunction
                (setf (cdr location) (funcall initfunction))))))))
    (setf (class-layout class)
          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
575
  (setf (class-default-initargs class)
576
        (compute-default-initargs class))
577
578
  (setf (class-finalized-p class) t))

579
580
581
582
583
(declaim (notinline finalize-inheritance))
(defun finalize-inheritance (class)
  (std-finalize-inheritance class))


584
585
586
587
;;; Class precedence lists

(defun std-compute-class-precedence-list (class)
  (let ((classes-to-order (collect-superclasses* class)))
588
589
590
591
    (dolist (super classes-to-order)
      (when (typep super 'forward-referenced-class)
        (error "Can't compute class precedence list for class ~A ~
                which depends on forward referenced class ~A." class super)))
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    (topological-sort classes-to-order
                      (remove-duplicates
                       (mapappend #'local-precedence-ordering
                                  classes-to-order))
                      #'std-tie-breaker-rule)))

;;; topological-sort implements the standard algorithm for topologically
;;; sorting an arbitrary set of elements while honoring the precedence
;;; constraints given by a set of (X,Y) pairs that indicate that element
;;; X must precede element Y.  The tie-breaker procedure is called when it
;;; is necessary to choose from multiple minimal elements; both a list of
;;; candidates and the ordering so far are provided as arguments.

(defun topological-sort (elements constraints tie-breaker)
  (let ((remaining-constraints constraints)
        (remaining-elements elements)
        (result ()))
    (loop
      (let ((minimal-elements
             (remove-if
              #'(lambda (class)
                 (member class remaining-constraints
                         :key #'cadr))
              remaining-elements)))
        (when (null minimal-elements)
          (if (null remaining-elements)
              (return-from topological-sort result)
              (error "Inconsistent precedence graph.")))
        (let ((choice (if (null (cdr minimal-elements))
                          (car minimal-elements)
                          (funcall tie-breaker
                                   minimal-elements
                                   result))))
          (setq result (append result (list choice)))
          (setq remaining-elements
                (remove choice remaining-elements))
          (setq remaining-constraints
                (remove choice
                        remaining-constraints
                        :test #'member)))))))

;;; In the event of a tie while topologically sorting class precedence lists,
;;; the CLOS Specification says to "select the one that has a direct subclass
;;; rightmost in the class precedence list computed so far."  The same result
;;; is obtained by inspecting the partially constructed class precedence list
;;; from right to left, looking for the first minimal element to show up among
;;; the direct superclasses of the class precedence list constituent.
;;; (There's a lemma that shows that this rule yields a unique result.)

(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
  (dolist (cpl-constituent (reverse cpl-so-far))
    (let* ((supers (class-direct-superclasses cpl-constituent))
           (common (intersection minimal-elements supers)))
      (when (not (null common))
        (return-from std-tie-breaker-rule (car common))))))

;;; This version of collect-superclasses* isn't bothered by cycles in the class
;;; hierarchy, which sometimes happen by accident.

(defun collect-superclasses* (class)
  (labels ((all-superclasses-loop (seen superclasses)
                                  (let ((to-be-processed
                                         (set-difference superclasses seen)))
                                    (if (null to-be-processed)
                                        superclasses
                                        (let ((class-to-process
                                               (car to-be-processed)))
                                          (all-superclasses-loop
                                           (cons class-to-process seen)
                                           (union (class-direct-superclasses
                                                   class-to-process)
                                                  superclasses)))))))
          (all-superclasses-loop () (list class))))

;;; The local precedence ordering of a class C with direct superclasses C_1,
;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).

(defun local-precedence-ordering (class)
  (mapcar #'list
          (cons class
                (butlast (class-direct-superclasses class)))
          (class-direct-superclasses class)))

;;; Slot inheritance

(defun std-compute-slots (class)
678
679
680
681
682
683
  (let* ((all-slots (mapappend #'(lambda (c) (class-direct-slots c))
                               ;; Slots of base class must come first
                               (reverse (class-precedence-list class))))
         (all-names (delete-duplicates
                     (mapcar 'slot-definition-name all-slots)
                     :from-end t)))
684
685
    (mapcar #'(lambda (name)
               (funcall
686
                (if (std-class-p class)
687
688
689
                    #'std-compute-effective-slot-definition
                    #'compute-effective-slot-definition)
                class
690
                name
691
692
693
694
695
696
                ;; Slot of inherited class must override initfunction,
                ;; documentation of base class
                (nreverse
                 (remove name all-slots
                         :key 'slot-definition-name
                         :test-not #'eq))))
697
698
            all-names)))

699
(defun std-compute-effective-slot-definition (class name direct-slots)
700
  (let ((initer (find-if-not #'null direct-slots
701
                             :key 'slot-definition-initfunction))
702
703
        (documentation-slot (find-if-not #'null direct-slots
                                         :key 'slot-definition-documentation))
704
705
        (types (delete-duplicates
                (delete t (mapcar #'slot-definition-type direct-slots))
706
                :test #'equal)))
707
    (make-effective-slot-definition
708
     class
709
     :name name
710
     :initform (if initer
711
                   (slot-definition-initform initer)
712
713
                   nil)
     :initfunction (if initer
714
                       (slot-definition-initfunction initer)
715
716
                       nil)
     :initargs (remove-duplicates
717
                (mapappend 'slot-definition-initargs
718
                           direct-slots))
719
     :allocation (slot-definition-allocation (car direct-slots))
720
     :allocation-class (when (slot-boundp (car direct-slots)
721
722
723
724
725
726
727
                                          'sys::allocation-class)
                         ;;for some classes created in Java
                         ;;(e.g. SimpleCondition) this slot is unbound
                         (slot-definition-allocation-class (car direct-slots)))
     :type (cond ((null types) t)
                 ((= 1 (length types)) types)
                 (t (list* 'and types)))
728
729
730
     :documentation (if documentation-slot
                        (documentation documentation-slot t)
                        nil))))
731
732
733
734
735
736
737
738

;;; Standard instance slot access

;;; N.B. The location of the effective-slots slots in the class metaobject for
;;; standard-class must be determined without making any further slot
;;; references.

(defun find-slot-definition (class slot-name)
739
  (dolist (slot (class-slots class) nil)
740
    (when (eq slot-name (slot-definition-name slot))
741
742
743
744
745
      (return slot))))

(defun slot-location (class slot-name)
  (let ((slot (find-slot-definition class slot-name)))
    (if slot
746
        (slot-definition-location slot)
747
748
749
750
751
752
753
        nil)))

(defun instance-slot-location (instance slot-name)
  (let ((layout (std-instance-layout instance)))
    (and layout (layout-slot-location layout slot-name))))

(defun slot-value (object slot-name)
754
755
756
757
758
759
760
761
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+)
            (eq metaclass +the-structure-class+)
            (eq metaclass +the-funcallable-standard-class+))
        (std-slot-value object slot-name)
        (slot-value-using-class class object
                                (find-slot-definition class slot-name)))))
762
763

(defun %set-slot-value (object slot-name new-value)
764
765
766
767
768
769
770
771
772
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+)
            (eq metaclass +the-structure-class+)
            (eq metaclass +the-funcallable-standard-class+))
        (setf (std-slot-value object slot-name) new-value)
        (setf (slot-value-using-class class object
                                      (find-slot-definition class slot-name))
              new-value))))
773
774
775
776

(defsetf slot-value %set-slot-value)

(defun slot-boundp (object slot-name)
777
778
  (let ((class (class-of object)))
    (if (std-class-p class)
779
780
781
        (std-slot-boundp object slot-name)
        (slot-boundp-using-class class object
                                 (find-slot-definition class slot-name)))))
782
783
784
785
786
787
788
789
790
791
792
793

(defun std-slot-makunbound (instance slot-name)
  (let ((location (instance-slot-location instance slot-name)))
    (cond ((fixnump location)
           (setf (standard-instance-access instance location) +slot-unbound+))
          ((consp location)
           (setf (cdr location) +slot-unbound+))
          (t
           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
  instance)

(defun slot-makunbound (object slot-name)
794
795
  (let ((class (class-of object)))
    (if (std-class-p class)
796
797
798
        (std-slot-makunbound object slot-name)
        (slot-makunbound-using-class class object
                                     (find-slot-definition class slot-name)))))
799
800

(defun std-slot-exists-p (instance slot-name)
801
  (not (null (find slot-name (class-slots (class-of instance))
802
                   :key 'slot-definition-name))))
803
804

(defun slot-exists-p (object slot-name)
805
806
807
808
  (let ((class (class-of object)))
    (if (std-class-p class)
        (std-slot-exists-p object slot-name)
        (slot-exists-p-using-class class object slot-name))))
809
810

(defun instance-slot-p (slot)
811
  (eq (slot-definition-allocation slot) :instance))
812

813
814
815
(defun std-allocate-instance (class)
  (sys::%std-allocate-instance class))

816
(defun allocate-funcallable-instance (class)
817
818
819
820
821
822
823
  (let ((instance (sys::%allocate-funcallable-instance class)))
    (set-funcallable-instance-function
     instance
     #'(lambda (&rest args)
         (declare (ignore args))
         (error 'program-error "Called a funcallable-instance with unset function.")))
    instance))
824

825
826
827
828
829
(declaim (notinline class-prototype))
(defun class-prototype (class)
  (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
  (std-allocate-instance class))

830
831
832
833
834
835
(defun maybe-finalize-class-subtree (class)
  (when (every #'class-finalized-p (class-direct-superclasses class))
    (finalize-inheritance class)
    (dolist (subclass (class-direct-subclasses class))
      (maybe-finalize-class-subtree subclass))))

836
(defun make-instance-standard-class (metaclass
837
                                     &rest initargs
838
                                     &key name direct-superclasses direct-slots
839
840
                                       direct-default-initargs
                                       documentation)
841
  (declare (ignore metaclass))
842
  (let ((class (std-allocate-instance +the-standard-class+)))
843
844
845
846
847
    (unless *clos-booting*
      (check-initargs (list #'allocate-instance #'initialize-instance)
                      (list* class initargs)
                      class t initargs
                      *make-instance-initargs-cache* 'make-instance))
848
    (%set-class-name name class)
849
850
851
    ;; KLUDGE: necessary in define-primordial-class, otherwise
    ;; StandardClass.getClassLayout() throws an error
    (unless *clos-booting* (%set-class-layout nil class))
852
853
    (%set-class-direct-subclasses ()  class)
    (%set-class-direct-methods ()  class)
854
855
856
857
858
859
860
    (%set-class-documentation class documentation)
    (std-after-initialization-for-classes class
                                          :direct-superclasses direct-superclasses
                                          :direct-slots direct-slots
                                          :direct-default-initargs direct-default-initargs)
    class))

861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
(defun make-or-find-instance-funcallable-standard-class
    (metaclass &rest initargs &key name direct-superclasses direct-slots
                                direct-default-initargs documentation)
  (declare (ignore metaclass initargs))
  (or (find-class name nil)
      (let ((class (std-allocate-instance +the-funcallable-standard-class+)))
        (%set-class-name name class)
        (unless *clos-booting* (%set-class-layout nil class))
        (%set-class-direct-subclasses ()  class)
        (%set-class-direct-methods ()  class)
        (%set-class-documentation class documentation)
        (std-after-initialization-for-classes class
                                              :direct-superclasses direct-superclasses
                                              :direct-slots direct-slots
                                              :direct-default-initargs direct-default-initargs)
        class)))

878
879
880
881
882
883
;(defun convert-to-direct-slot-definition (class canonicalized-slot)
;  (apply #'make-instance
;         (apply #'direct-slot-definition-class
;                class canonicalized-slot)
;         canonicalized-slot))

884
885
886
887
888
889
890
(defun canonicalize-direct-superclass-list (class direct-superclasses)
  (cond (direct-superclasses)
        ((subtypep (class-of class) +the-funcallable-standard-class+)
         (list +the-funcallable-standard-object-class+))
        ((subtypep (class-of class) +the-standard-class+)
         (list +the-standard-object-class+))))

891
892
893
894
(defun std-after-initialization-for-classes (class
                                             &key direct-superclasses direct-slots
                                             direct-default-initargs
                                             &allow-other-keys)
895
  (let ((supers (canonicalize-direct-superclass-list class direct-superclasses)))
896
897
    (setf (class-direct-superclasses class) supers)
    (dolist (superclass supers)
898
      (add-direct-subclass superclass class)))
899
900
901
902
903
  (let ((slots (mapcar #'(lambda (slot-properties)
                          (apply #'make-direct-slot-definition class slot-properties))
                       direct-slots)))
    (setf (class-direct-slots class) slots)
    (dolist (direct-slot slots)
904
      (dolist (reader (slot-definition-readers direct-slot))
905
        (add-reader-method class reader direct-slot))
906
      (dolist (writer (slot-definition-writers direct-slot))
907
        (add-writer-method class writer direct-slot))))
908
  (setf (class-direct-default-initargs class) direct-default-initargs)
909
  (maybe-finalize-class-subtree class)
910
911
  (values))

912
913
914
915
916
917
(defmacro define-primordial-class (name superclasses direct-slots)
  "Primitive class definition tool.
No non-standard metaclasses, accessor methods, duplicate slots,
non-existent superclasses, default initargs, or other complicated stuff.
Handle with care."
  (let ((class (gensym)))
918
919
920
921
922
    `(let ((,class (make-instance-standard-class
                    nil
                    :name ',name
                    :direct-superclasses ',(mapcar #'find-class superclasses)
                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
923
924
925
       (%set-find-class ',name ,class)
       ,class)))

926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
(defmacro define-funcallable-primordial-class (name superclasses direct-slots)
  "Primitive funcallable class definition tool.
No non-standard metaclasses, accessor methods, duplicate slots,
non-existent superclasses, default initargs, or other complicated stuff.
Handle with care.
Will not modify existing classes to avoid breaking std-generic-function-p."
  (let ((class (gensym)))
    `(let ((,class (make-or-find-instance-funcallable-standard-class
                    nil
                    :name ',name
                    :direct-superclasses ',(mapcar #'find-class superclasses)
                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
       (%set-find-class ',name ,class)
       ,class)))

941
942
943
944
(define-primordial-class eql-specializer (specializer)
  ((object :initform nil)
   (direct-methods :initform nil)))

945
(define-primordial-class method-combination (metaobject)
946
  ((sys::name :initarg :name :initform nil)
947
948
949
950
   (sys::%documentation :initarg :documentation :initform nil)
   (options :initarg :options :initform nil)))

(define-primordial-class short-method-combination (method-combination)
951
952
  ((operator :initarg :operator)
   (identity-with-one-argument :initarg :identity-with-one-argument)))
953
954

(define-primordial-class long-method-combination (method-combination)
955
956
957
958
959
960
961
962
  ((sys::lambda-list :initarg :lambda-list)
   (method-group-specs :initarg :method-group-specs)
   (args-lambda-list :initarg :args-lambda-list)
   (generic-function-symbol :initarg :generic-function-symbol)
   (function :initarg :function)
   (arguments :initarg :arguments)
   (declarations :initarg :declarations)
   (forms :initarg :forms)))
963

964
965
966
967
968
969
970
971
972
973
974
975
976
(define-primordial-class standard-accessor-method (standard-method)
  ((sys::%slot-definition :initarg :slot-definition :initform nil)))

(define-primordial-class standard-reader-method (standard-accessor-method)
  ())
(defconstant +the-standard-reader-method-class+
  (find-class 'standard-reader-method))

(define-primordial-class standard-writer-method (standard-accessor-method)
  ())
(defconstant +the-standard-writer-method-class+
  (find-class 'standard-writer-method))

977
978
979
980
(define-primordial-class structure-class (class)
  ())
(defconstant +the-structure-class+ (find-class 'structure-class))

981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
(define-primordial-class forward-referenced-class (class)
  ;; The standard-class layout.  Not all of these slots are necessary,
  ;; but at least NAME and DIRECT-SUBCLASSES are.
  ((sys::name :initarg :name :initform nil)
   (sys::layout :initform nil)
   (sys::direct-superclasses :initform nil)
   (sys::direct-subclasses :initform nil)
   (sys::precedence-list :initform nil)
   (sys::direct-methods :initform nil)
   (sys::direct-slots :initform nil)
   (sys::slots :initform nil)
   (sys::direct-default-initargs :initform nil)
   (sys::default-initargs :initform nil)
   (sys::finalized-p :initform nil)
   (sys::%documentation :initform nil)))
(defconstant +the-forward-referenced-class+
  (find-class 'forward-referenced-class))
998

999
1000
(define-funcallable-primordial-class standard-generic-function (generic-function)
  ((sys::name :initarg :name :initform nil)
For faster browsing, not all history is shown. View entire blame