1
;;;; Copyright (c) 1992, Giuseppe Attardi.
3
;;;; This program is free software; you can redistribute it and/or
4
;;;; modify it under the terms of the GNU Library General Public
5
;;;; License as published by the Free Software Foundation; either
6
;;;; version 2 of the License, or (at your option) any later version.
8
;;;; See file '../Copyright' for full details.
12
(:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"
13
"SIMPLE-PROGRAM-ERROR"))
17
(defconstant *default-method-cache-size* 64 "Size of hash tables for methods")
19
;;;----------------------------------------------------------------------
20
;;; BOOTSTRAP FUNCTIONS TO ACCESS SLOTS
22
;;; ECL has some restictions regarding the basic classes CLASS,
23
;;; STANDARD-CLASS and STANDARD-GENERIC-FUNCTION. These are that, certain
24
;;; slots must have pre-defined positions which cannot change. That means
25
;;; that a user can extend these classes, but they must be the first ones
26
;;; in the class hierarchy, and the position of their slots must not change.
28
(eval-when (compile eval)
29
(defun create-accessors (slotds type)
33
(dolist (s slotds `(progn ,@output))
34
(when (setf name (getf (cdr s) :accessor))
35
(remf (cdr s) :accessor)
39
(si:instance-ref obj ,i))
40
(defsetf ,name (obj) (x)
41
`(si:instance-set ,obj ,,i ,x))
43
(define-compiler-macro ,name (obj)
44
`(si:instance-ref ,obj ,,i))
49
;;; ----------------------------------------------------------------------
52
(eval-when (compile eval)
53
(defparameter +class-slots+
54
'((name :initarg :name :initform nil :accessor class-id)
55
(direct-superclasses :initarg :direct-superclasses
56
:accessor class-direct-superclasses)
57
(direct-subclasses :initform nil :accessor class-direct-subclasses)
58
(slots :accessor class-slots)
59
(precedence-list :accessor class-precedence-list)
60
(direct-slots :initarg :direct-slots :accessor class-direct-slots)
61
(direct-default-initargs :initarg :direct-default-initargs
62
:initform nil :accessor class-direct-default-initargs)
63
(default-initargs :accessor class-default-initargs)
64
(finalized :initform nil :accessor class-finalized-p)
65
(documentation :initarg :documentation :initform nil)
68
#.(create-accessors +class-slots+ 'class)
70
;;; ----------------------------------------------------------------------
73
(eval-when (compile eval)
74
(defparameter +standard-class-slots+
76
'((slot-table :accessor slot-table)
77
(optimize-slot-access)
80
#.(create-accessors +standard-class-slots+ 'standard-class)
82
;;; ----------------------------------------------------------------------
83
;;; STANDARD-GENERIC-FUNCTION
85
(eval-when (compile eval)
86
(defparameter +standard-generic-function-slots+
87
'((name :initarg :name :initform nil
88
:accessor generic-function-name)
89
(method-hash :accessor generic-function-method-hash
90
:initform (make-hash-table
92
;; use fixnums as limits for efficiency:
93
:size *default-method-cache-size*
94
:rehash-size #.(/ *default-method-cache-size* 2)
95
:rehash-threshold 0.5s0))
96
(spec-list :initform nil :accessor generic-function-spec-list)
98
:initarg :method-combination :initform '(standard)
99
:accessor generic-function-method-combination)
100
(lambda-list :initarg :lambda-list
101
:accessor generic-function-lambda-list)
102
(argument-precedence-order
103
:initarg :argument-precedence-order
105
:accessor generic-function-argument-precedence-order)
107
:initarg :method-class
108
:initform (find-class 'standard-method)
109
:accessor generic-function-method-class)
110
(documentation :initarg :documentation :initform nil)
111
(methods :initform nil :accessor generic-function-methods)
112
(a-p-o-function :initform nil :accessor generic-function-a-p-o-function))))
114
#.(create-accessors +standard-generic-function-slots+
115
'standard-generic-function)
117
;;; ----------------------------------------------------------------------
120
(eval-when (compile eval)
121
(defparameter +standard-method-slots+
122
'((generic-function :initarg :generic-function :initform nil
123
:accessor method-generic-function)
124
(lambda-list :initarg :lambda-list
125
:accessor method-lambda-list)
126
(specializers :initarg :specializers :accessor method-specializers)
127
(qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers)
128
(function :initarg :function :accessor method-function)
129
(documentation :initform nil :initarg documentation)
130
(plist :initform nil :initarg :plist :accessor method-plist))))
132
#.(create-accessors +standard-method-slots+ 'standard-method)
134
;;; ----------------------------------------------------------------------
136
;;; FIND-CLASS naming classes.
139
;;; (FIND-CLASS <name>) returns the class named <name>. setf can be used
140
;;; with find-class to set the class named <name>. These are "extrinsic"
141
;;; names. Neither find-class nor setf of find-class do anything with the
142
;;; name slot of the class, they only lookup and change the association from
145
;;; This is only used during boot. The real one is in built-in.
147
(defun setf-find-class (new-value class &optional errorp env)
148
(warn "Ignoring class definition for ~S" class)))
150
(defun setf-find-class (new-value name &optional errorp env)
151
(let ((old-class (find-class name nil)))
154
(or (typep old-class 'built-in-class)
155
(member name '(class built-in-class) :test #'eq)))
156
(error "The class associated to the CL specifier ~S cannot be changed."
159
(setf (gethash name si:*class-name-hash-table*) new-value))
160
((null new-value) (remhash name si:*class-name-hash-table*))
161
(t (error "~A is not a class." new-value))))
164
(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x))
167
(and (si:instancep obj)
168
(let ((topmost (find-class 'CLASS nil)))
169
;; All instances can be classes until the class CLASS has
170
;; been installed. Otherwise, we check the parents.
172
(si::subclassp (si::instance-class obj) topmost)))
175
;;; ----------------------------------------------------------------------
178
(defun install-method (name qualifiers specializers lambda-list doc plist
180
(declare (ignore doc)
181
(notinline ensure-generic-function))
182
; (record-definition 'method `(method ,name ,@qualifiers ,specializers))
183
(let* ((gf (ensure-generic-function name))
184
(specializers (mapcar #'(lambda (x)
187
((si::instancep x) x)
190
(method (make-method qualifiers specializers lambda-list
192
(generic-function-method-class gf))))
193
(add-method gf method)
196
;;; ----------------------------------------------------------------------
199
;;; early version used during bootstrap
200
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
201
(if (and (fboundp name) (si::instancep (fdefinition name)))
203
;; create a fake standard-generic-function object:
204
(let ((gfun (si:allocate-raw-instance nil (find-class 't)
205
#.(length +standard-generic-function-slots+)))
206
(hash (make-hash-table
208
;; use fixnums as limits for efficiency:
209
:size *default-method-cache-size*
210
:rehash-size #.(/ *default-method-cache-size* 2)
211
:rehash-threshold 0.5s0)))
212
(declare (type standard-object gfun))
214
(si::instance-sig-set gfun)
215
(setf (generic-function-name gfun) name
216
(generic-function-lambda-list gfun) lambda-list
217
(generic-function-method-combination gfun) '(standard)
218
(generic-function-methods gfun) nil
219
(generic-function-spec-list gfun) nil
220
(generic-function-method-hash gfun) hash)
222
(setf (generic-function-argument-precedence-order gfun)
223
(rest (si::process-lambda-list lambda-list t))))
224
(si::set-funcallable gfun t)
225
(setf (fdefinition name) gfun)
229
;;; ----------------------------------------------------------------------
230
;;; COMPUTE-APPLICABLE-METHODS
233
(defun compute-applicable-methods (gf args)
234
(declare (optimize (safety 0) (speed 3)))
235
(let* ((methods (generic-function-methods gf))
238
;; first compute the applicable method list
239
(dolist (method methods)
240
;; for each method in the list
241
(do* ((scan-args args (cdr scan-args))
242
(scan-specializers (method-specializers method)
243
(cdr scan-specializers))
246
;; check if the method is applicable verifying
247
;; if each argument satisfies the corresponding
248
;; parameter specializers
249
((null scan-args) (push method applicable-list))
250
(setq arg (first scan-args)
251
spec (first scan-specializers))
252
(unless (or (null spec)
253
(and (consp spec) (eql arg (second spec)))
257
(push (class-of arg) args-specializers))
258
(setq args-specializers (nreverse args-specializers))
259
;; then order the list
260
(do* ((scan applicable-list)
261
(most-specific (first scan) (first scan))
262
(f (generic-function-a-p-o-function gf))
264
((null (cdr scan)) (when most-specific
265
;; at least one method
266
;(print (mapcar #'method-specializers
267
; (reverse (cons most-specific ordered-list))))
269
(push most-specific ordered-list))))
270
(dolist (meth (cdr scan))
271
(when (eq (compare-methods most-specific
272
meth args-specializers f) 2)
273
(setq most-specific meth)))
274
(setq scan (delete most-specific scan))
275
(push most-specific ordered-list))))
277
;;; ----------------------------------------------------------------------
278
;;; method comparison
280
(defun compare-methods (method-1 method-2 args-specializers f)
281
(declare (si::c-local))
282
(let* ((specializers-list-1 (method-specializers method-1))
283
(specializers-list-2 (method-specializers method-2)))
284
(compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
285
(if f (funcall f specializers-list-2) specializers-list-2)
288
(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
289
(declare (si::c-local))
290
(when (or spec-list-1 spec-list-2)
291
(ecase (compare-specializers (first spec-list-1)
293
(first args-specializers))
297
(compare-specializers-lists (cdr spec-list-1)
299
(cdr args-specializers)))
301
(error "The type specifiers ~S and ~S can not be disambiguated~
302
with respect to the argument specializer: ~S"
303
(or (car spec-list-1) t)
304
(or (car spec-list-2) t)
305
(car args-specializers)))))
308
(defun compare-specializers (spec-1 spec-2 arg-class)
309
(declare (si::c-local))
310
(let* ((cpl (class-precedence-list arg-class)))
311
(cond ((equal spec-1 spec-2) '=)
314
((subtypep spec-1 spec-2) '1)
315
((subtypep spec-2 spec-1) '2)
316
((and (listp spec-1) (eq (car spec-1) 'eql)) '1) ; is this engough?
317
((and (listp spec-2) (eq (car spec-2) 'eql)) '2) ; Beppe
318
((member spec-1 (member spec-2 cpl)) '2)
319
((member spec-2 (member spec-1 cpl)) '1)
320
(t (error "Complex type specifiers are not yet supported."))
323
(defun compute-g-f-spec-list (gf)
324
(flet ((nupdate-spec-how-list (spec-how-list specializers gf)
325
;; FIXME! This check should have happened before, shouldn't it???
326
(let ((l (length specializers)))
328
(unless (= (length spec-how-list) l)
329
(error "The generic function ~A~%has ~D required arguments, but the new specialization provides ~D."
330
gf (length spec-how-list) l))
331
(setf spec-how-list (make-list l))))
332
;; update the spec-how of the gfun
333
;; computing the or of the previous value and the new one
334
(do* ((l specializers (cdr l))
335
(l2 spec-how-list (cdr l2))
339
(setq spec-how (first l) spec-how-old (first l2))
341
(if (consp spec-how) ; an eql list
342
(if (consp spec-how-old)
343
(list* (second spec-how) spec-how-old)
345
(if (consp spec-how-old)
347
(or spec-how spec-how-old)))))
349
(let* ((spec-how-list nil)
351
(a-p-o (generic-function-argument-precedence-order gf)))
352
(dolist (method (generic-function-methods gf))
354
(nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
355
(setf (generic-function-spec-list gf)
356
(loop for type in spec-how-list
357
for name in (generic-function-lambda-list gf)
359
when type collect (cons type (position name a-p-o))))
360
(let* ((g-f-l-l (generic-function-lambda-list gf)))
361
(when (consp g-f-l-l)
362
(let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
363
(unless (equal a-p-o required-arguments)
365
(coerce `(lambda (%list)
366
(destructuring-bind ,required-arguments %list
369
(setf (generic-function-a-p-o-function gf) function)
370
(clrhash (generic-function-method-hash gf)))))
372
(defun print-object (object stream)
373
(print-unreadable-object (object stream)))
b'\\ No newline at end of file'
added
removed
src/clos/kernel.lsp
