1
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
3
;;; *************************************************************************
4
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5
;;; All rights reserved.
7
;;; Use and copying of this software and preparation of derivative works
8
;;; based upon this software are permitted. Any distribution of this
9
;;; software or derivative works must comply with all applicable United
10
;;; States export control laws.
12
;;; This software is made available AS IS, and Xerox Corporation makes no
13
;;; warranty about the software, its performance or its conformity to any
16
;;; Any person obtaining a copy of this software is requested to send their
17
;;; name and post office or electronic mail address to:
18
;;; CommonLoops Coordinator
20
;;; 3333 Coyote Hill Rd.
21
;;; Palo Alto, CA 94304
22
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
24
;;; Suggestions, comments and requests for improvements are also welcome.
25
;;; *************************************************************************
31
;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
33
;;; The original motiviation for this function was to deal with the bug in
34
;;; the Genera compiler that prevents lambda expressions in top-level forms
35
;;; other than DEFUN from being compiled.
37
;;; Now this function is used to grab other functionality as well. This
39
;;; - Preventing the grouping of top-level forms. For example, a
40
;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped
41
;;; into the same top-level form.
42
;;; - Telling the programming environment what the pretty version
43
;;; of the name of this form is. This is used by WARN.
45
(defun make-top-level-form (name times form)
46
(flet ((definition-name ()
48
(memq (car name) '(defmethod defclass class method method-combination)))
49
(format nil "~A~{ ~S~}"
50
(capitalize-words (car name) ()) (cdr name))
51
(format nil "~S" name))))
56
(let ((thunk-name (gensym "TOP-LEVEL-FORM")))
59
(declare (sys:function-parent
62
(defmethod `(method ,@(rest name)))
63
(otherwise (second name))))
67
((defmethod defgeneric) 'defun)
68
((defclass) 'defclass)
69
(otherwise (first name))))
74
`(compiler-let ((compiler:default-warning-function ',name))
77
(declare ,(cond ((listp name)
80
`(sys:function-parent ,(second name) defclass))
82
`(sys:function-name (method ,@(rest name))))
84
`(sys:function-name ,(second name)))
86
`(sys:function-name ,name))))
88
`(sys:function-name ,name))))
91
`(compiler-let ((lucid::*compiler-message-string*
92
(or lucid::*compiler-message-string*
94
(eval-when ,times ,form))
96
(if (member 'compile times)
97
`(eval-when ,times ,form)
100
(let* ((*print-pretty* nil)
101
(thunk-name (gensym (definition-name))))
102
(gensym "G") ; set the prefix back to something less confusing.
104
(defun ,thunk-name ()
107
#-(or Genera LCL3.0 cmu kcl)
108
(make-progn `',name `(eval-when ,times ,form))))
110
(defun make-progn (&rest forms)
111
(let ((progn-form nil))
112
(labels ((collect-forms (forms)
114
(collect-forms (cdr forms))
115
(if (and (listp (car forms))
116
(eq (caar forms) 'progn))
117
(collect-forms (cdar forms))
118
(push (car forms) progn-form)))))
119
(collect-forms forms)
120
(cons 'progn progn-form))))
125
;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
126
;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta-
127
;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
128
;;; collects all class definitions up, when the metabraid is initialized it
129
;;; is done from those class definitions.
131
;;; After the metabraid has been setup, and the protocol for defining classes
132
;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
133
;;; file defclass.lisp
135
(defmacro DEFCLASS (name direct-superclasses direct-slots &rest options)
136
(declare (indentation 2 4 3 1))
137
(expand-defclass name direct-superclasses direct-slots options))
139
(defun expand-defclass (name supers slots options)
140
(declare (special *defclass-times* *boot-state* *the-class-structure-class*))
141
(setq supers (copy-tree supers)
142
slots (copy-tree slots)
143
options (copy-tree options))
144
(let ((metaclass 'standard-class))
145
(dolist (option options)
146
(if (not (listp option))
147
(error "~S is not a legal defclass option." option)
148
(when (eq (car option) ':metaclass)
149
(unless (legal-class-name-p (cadr option))
150
(error "The value of the :metaclass option (~S) is not a~%~
154
(setq metaclass (cadr option))
158
(lisp:standard-class 'standard-class)
159
(lisp:structure-class 'structure-class)
161
(setf options (remove option options))
164
(let ((*initfunctions* ())
165
(*accessors* ()) ;Truly a crock, but we got
166
(*readers* ()) ;to have it to live nicely.
168
(declare (special *initfunctions* *accessors* *readers* *writers*))
169
(let ((canonical-slots
170
(mapcar #'(lambda (spec)
171
(canonicalize-slot-specification name spec))
174
(mapcar #'(lambda (option)
175
(canonicalize-defclass-option name option))
177
(defstruct-p (and (eq *boot-state* 'complete)
178
(let ((mclass (find-class metaclass nil)))
181
*the-class-structure-class*))))))
182
(do-standard-defsetfs-for-defclass *accessors*)
184
(make-top-level-form `(defclass ,name)
185
(if defstruct-p '(load eval) *defclass-times*)
187
,@(mapcar #'(lambda (x)
188
`(declaim (ftype (function (t) t) ,x)))
189
#+cmu *readers* #-cmu nil)
190
,@(mapcar #'(lambda (x)
191
#-setf (when (consp x)
192
(setq x (get-setf-function-name (cadr x))))
193
`(declaim (ftype (function (t t) t) ,x)))
194
#+cmu *writers* #-cmu nil)
195
(let ,(mapcar #'cdr *initfunctions*)
196
(load-defclass ',name
199
(list ,@canonical-slots)
200
(list ,@(apply #'append
202
'(:from-defclass-p t))
207
(eval defclass-form) ; define the class now, so that
208
`(progn ; the defstruct can be compiled.
209
,(class-defstruct-form (find-class name))
212
(when (and (eq *boot-state* 'complete)
213
(not (member 'compile *defclass-times*)))
214
(inform-type-system-about-std-class name))
217
(defun make-initfunction (initform)
218
(declare (special *initfunctions*))
219
(cond ((or (eq initform 't)
220
(equal initform ''t))
222
((or (eq initform 'nil)
223
(equal initform ''nil))
225
((or (eql initform '0)
226
(equal initform ''0))
229
(let ((entry (assoc initform *initfunctions* :test #'equal)))
231
(setq entry (list initform
233
`(function (lambda () ,initform))))
234
(push entry *initfunctions*))
237
(defun canonicalize-slot-specification (class-name spec)
238
(declare (special *accessors* *readers* *writers*))
239
(cond ((and (symbolp spec)
240
(not (keywordp spec))
241
(not (memq spec '(t nil))))
244
(error "~S is not a legal slot specification." spec))
246
`'(:name ,(car spec)))
248
(error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
250
class-name spec (list (car spec) :initform (cadr spec))))
252
(let* ((name (pop spec))
256
(unsupplied (list nil))
257
(initform (getf spec :initform unsupplied)))
258
(doplist (key val) spec
260
(:accessor (push val *accessors*)
262
(push `(setf ,val) writers))
263
(:reader (push val readers))
264
(:writer (push val writers))
265
(:initarg (push val initargs))))
266
(loop (unless (remf spec :accessor) (return)))
267
(loop (unless (remf spec :reader) (return)))
268
(loop (unless (remf spec :writer) (return)))
269
(loop (unless (remf spec :initarg) (return)))
270
(setq *writers* (append writers *writers*))
271
(setq *readers* (append readers *readers*))
272
(setq spec `(:name ',name
277
(if (eq initform unsupplied)
279
`(list* :initfunction ,(make-initfunction initform) ,@spec))))))
281
(defun canonicalize-defclass-option (class-name option)
282
(declare (ignore class-name))
285
(let ((canonical ()))
286
(let (key val (tail (cdr option)))
287
(loop (when (null tail) (return nil))
290
(push ``(,',key ,,(make-initfunction val) ,',val) canonical))
291
`(':direct-default-initargs (list ,@(nreverse canonical))))))
293
`(',(car option) ',(cdr option)))))
297
;;; This is the early definition of load-defclass. It just collects up all
298
;;; the class definitions in a list. Later, in the file braid1.lisp, these
299
;;; are actually defined.
304
;;; Each entry in *early-class-definitions* is an early-class-definition.
307
(defparameter *early-class-definitions* ())
309
(defun early-class-definition (class-name)
310
(or (find class-name *early-class-definitions* :key #'ecd-class-name)
311
(error "~S is not a class in *early-class-definitions*." class-name)))
313
(defun make-early-class-definition
314
(name source metaclass
315
superclass-names canonical-slots other-initargs)
316
(list 'early-class-definition
317
name source metaclass
318
superclass-names canonical-slots other-initargs))
320
(defun ecd-class-name (ecd) (nth 1 ecd))
321
(defun ecd-source (ecd) (nth 2 ecd))
322
(defun ecd-metaclass (ecd) (nth 3 ecd))
323
(defun ecd-superclass-names (ecd) (nth 4 ecd))
324
(defun ecd-canonical-slots (ecd) (nth 5 ecd))
325
(defun ecd-other-initargs (ecd) (nth 6 ecd))
327
(defvar *early-class-slots* nil)
329
(defun canonical-slot-name (canonical-slot)
330
(getf canonical-slot :name))
332
(defun early-class-slots (class-name)
333
(cdr (or (assoc class-name *early-class-slots*)
334
(let ((a (cons class-name
335
(mapcar #'canonical-slot-name
336
(early-collect-inheritance class-name)))))
337
(push a *early-class-slots*)
340
(defun early-class-size (class-name)
341
(length (early-class-slots class-name)))
343
(defun early-collect-inheritance (class-name)
344
;;(declare (values slots cpl default-initargs direct-subclasses))
345
(let ((cpl (early-collect-cpl class-name)))
346
(values (early-collect-slots cpl)
348
(early-collect-default-initargs cpl)
349
(gathering1 (collecting)
350
(dolist (definition *early-class-definitions*)
351
(when (memq class-name (ecd-superclass-names definition))
352
(gather1 (ecd-class-name definition))))))))
354
(defun early-collect-slots (cpl)
355
(let* ((definitions (mapcar #'early-class-definition cpl))
356
(super-slots (mapcar #'ecd-canonical-slots definitions))
357
(slots (apply #'append (reverse super-slots))))
359
(let ((name1 (canonical-slot-name s1)))
360
(dolist (s2 (cdr (memq s1 slots)))
361
(when (eq name1 (canonical-slot-name s2))
362
(error "More than one early class defines a slot with the~%~
363
name ~S. This can't work because the bootstrap~%~
364
object system doesn't know how to compute effective~%~
369
(defun early-collect-cpl (class-name)
371
(let* ((definition (early-class-definition c))
372
(supers (ecd-superclass-names definition)))
374
(apply #'append (mapcar #'early-collect-cpl supers))))))
375
(remove-duplicates (walk class-name) :from-end nil :test #'eq)))
377
(defun early-collect-default-initargs (cpl)
378
(let ((default-initargs ()))
379
(dolist (class-name cpl)
380
(let* ((definition (early-class-definition class-name))
381
(others (ecd-other-initargs definition)))
382
(loop (when (null others) (return nil))
383
(let ((initarg (pop others)))
384
(unless (eq initarg :direct-default-initargs)
385
(error "The defclass option ~S is not supported by the bootstrap~%~
388
(setq default-initargs
389
(nconc default-initargs (reverse (pop others)))))))
390
(reverse default-initargs)))
392
(defun bootstrap-slot-index (class-name slot-name)
393
(or (position slot-name (early-class-slots class-name))
394
(error "~S not found" slot-name)))
397
;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
398
;;; the values of slots during bootstrapping. During bootstrapping, there
399
;;; are only two kinds of objects whose slots we need to access, CLASSes
400
;;; and SLOT-DEFINITIONs. The first argument to these functions tells whether the
401
;;; object is a CLASS or a SLOT-DEFINITION.
403
;;; Note that the way this works it stores the slot in the same place in
404
;;; memory that the full object system will expect to find it later. This
405
;;; is critical to the bootstrapping process, the whole changeover to the
406
;;; full object system is predicated on this.
408
;;; One important point is that the layout of standard classes and standard
409
;;; slots must be computed the same way in this file as it is by the full
410
;;; object system later.
412
(defmacro bootstrap-get-slot (type object slot-name)
413
`(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
415
(defun bootstrap-set-slot (type object slot-name new-value)
416
(setf (bootstrap-get-slot type object slot-name) new-value))
418
(defun early-class-name (class)
419
(bootstrap-get-slot 'class class 'name))
421
(defun early-class-precedence-list (class)
422
(bootstrap-get-slot 'pcl-class class 'class-precedence-list))
424
(defun early-class-name-of (instance)
425
(early-class-name (class-of instance)))
427
(defun early-class-slotds (class)
428
(bootstrap-get-slot 'slot-class class 'slots))
430
(defun early-slot-definition-name (slotd)
431
(bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
433
(defun early-slot-definition-location (slotd)
434
(bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
436
(defun early-accessor-method-slot-name (method)
437
(bootstrap-get-slot 'standard-accessor-method method 'slot-name))
439
(unless (fboundp 'class-name-of)
440
(setf (symbol-function 'class-name-of)
441
(symbol-function 'early-class-name-of)))
443
(defun early-class-direct-subclasses (class)
444
(bootstrap-get-slot 'class class 'direct-subclasses))
446
(proclaim '(notinline load-defclass))
448
(name metaclass supers canonical-slots canonical-options accessor-names)
449
(setq supers (copy-tree supers)
450
canonical-slots (copy-tree canonical-slots)
451
canonical-options (copy-tree canonical-options))
452
(do-standard-defsetfs-for-defclass accessor-names)
453
(when (eq metaclass 'standard-class)
454
(inform-type-system-about-std-class name))
456
(make-early-class-definition name
463
(find name *early-class-definitions* :key #'ecd-class-name)))
464
(setq *early-class-definitions*
465
(cons ecd (remove existing *early-class-definitions*)))
added
removed
pcl/pcl_defclass.lisp
