Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[93be6c]: src / clos / kernel.lsp Maximize Restore History

Download this file

kernel.lsp    399 lines (372 with data), 15.5 kB

  1
  2
  3
  4
  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
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
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
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
;;;;
;;;; Copyright (c) 1992, Giuseppe Attardi.
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "CLOS")
(defparameter *clos-booted* nil)
;;; ----------------------------------------------------------------------
;;;
;;; FIND-CLASS naming classes.
;;;
;;;
;;; (FIND-CLASS <name>) returns the class named <name>. setf can be used
;;; with find-class to set the class named <name>. These are "extrinsic"
;;; names. Neither find-class nor setf of find-class do anything with the
;;; name slot of the class, they only lookup and change the association from
;;; name to class.
;;;
;;; This is only used during boot. The real one is in built-in.
(eval-when (compile)
(defun setf-find-class (new-value class &optional errorp env)
(warn "Ignoring class definition for ~S" class)))
(defun setf-find-class (new-value name &optional errorp env)
(declare (ignore errorp env))
(let ((old-class (find-class name nil)))
(cond
((and old-class
(or (typep old-class 'built-in-class)
(member name '(class built-in-class) :test #'eq)))
(unless (eq new-value old-class)
(error "The class associated to the CL specifier ~S cannot be changed."
name)))
((classp new-value)
(setf (gethash name si:*class-name-hash-table*) new-value))
((null new-value) (remhash name si:*class-name-hash-table*))
(t (error "~A is not a class." new-value))))
new-value)
(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x))
(defun classp (obj)
(and (si:instancep obj)
(let ((topmost (find-class 'CLASS nil)))
;; All instances can be classes until the class CLASS has
;; been installed. Otherwise, we check the parents.
;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost))))
(or (null topmost)
(si::subclassp (si::instance-class obj) topmost)))
t))
;;; ----------------------------------------------------------------------
;;; Methods
(defun install-method (name qualifiers specializers lambda-list fun wrap &rest options)
(declare (ignore doc)
(notinline ensure-generic-function))
; (record-definition 'method `(method ,name ,@qualifiers ,specializers))
(let* ((gf (ensure-generic-function name))
(fun (if wrap (wrapped-method-function fun) fun))
(specializers (mapcar #'(lambda (x)
(cond ((consp x) (intern-eql-specializer (second x)))
((typep x 'specializer) x)
((find-class x nil))
(t
(error "In method definition for ~A, found an invalid specializer ~A" name specializers))))
specializers))
(method (make-method (generic-function-method-class gf)
qualifiers specializers lambda-list
fun options)))
(add-method gf method)
method))
(defun wrapped-method-function (method-function)
#'(lambda (.combined-method-args. *next-methods*)
(declare (special .combined-method-args. *next-methods*))
(apply method-function .combined-method-args.)))
;;; ----------------------------------------------------------------------
;;; early versions
;;; early version used during bootstrap
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
(if (and (fboundp name) (si::instancep (fdefinition name)))
(fdefinition name)
;; create a fake standard-generic-function object:
(with-early-make-instance +standard-generic-function-slots+
(gfun (find-class 'standard-generic-function)
:name name
:spec-list nil
:method-combination (find-method-combination nil 'standard nil)
:lambda-list lambda-list
:argument-precedence-order
(and l-l-p (rest (si::process-lambda-list lambda-list t)))
:method-class (find-class 'standard-method)
:docstring nil
:methods nil
:a-p-o-function nil
:declarations nil
:dependents nil)
;; create a new gfun
(set-funcallable-instance-function gfun 'standard-generic-function)
(setf (fdefinition name) gfun)
gfun)))
(defun (setf generic-function-name) (new-name gf)
(if *clos-booted*
(reinitialize-instance gf :name new-name)
(setf (slot-value gf 'name) new-name)))
(defun default-dispatch (generic-function)
(cond ((null *clos-booted*)
'standard-generic-function)
((eq (class-id (class-of generic-function))
'standard-generic-function)
'standard-generic-function)
(t)))
(defun compute-discriminating-function (generic-function)
(values #'(lambda (&rest args)
(multiple-value-bind (method-list ok)
(compute-applicable-methods-using-classes
generic-function
(mapcar #'class-of args))
(unless ok
(setf method-list
(compute-applicable-methods generic-function args))
(unless method-list
(no-applicable-methods generic-function args)))
(funcall (compute-effective-method-function
generic-function
(generic-function-method-combination generic-function)
method-list)
args
nil)))
t))
(defun set-generic-function-dispatch (gfun)
;;
;; We have to decide which discriminating function to install:
;; 1* One supplied by the user
;; 2* One coded in C that follows the MOP
;; 3* One in C specialized for slot accessors
;; 4* One in C that does not use generic versions of compute-applicable-...
;; Respectively
;; 1* The user supplies a discriminating function, or the number of arguments
;; is so large that they cannot be handled by the C dispatchers with
;; with memoization.
;; 2* The generic function is not a s-g-f but takes less than 64 arguments
;; 3* The generic function is a standard-generic-function and all its slots
;; are standard-{reader,writer}-slots
;; 4* The generic function is a standard-generic-function with less
;; than 64 arguments
;;
;; This chain of reasoning uses the fact that the user cannot override methods
;; such as COMPUTE-APPLICABLE-METHODS, or COMPUTE-EFFECTIVE-METHOD, or
;; COMPUTE-DISCRIMINATING-FUNCTION acting on STANDARD-GENERIC-FUNCTION.
;;
(declare (notinline compute-discriminating-function))
(multiple-value-bind (default-function optimizable)
;;
;; If the class is not a standard-generic-function, we must honor whatever function
;; the user provides. However, we still recognize the case without user-computed
;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with
;; a similar implementation in C
(compute-discriminating-function gfun)
(let ((methods (slot-value gfun 'methods)))
(set-funcallable-instance-function
gfun
(cond
;; Case 1*
((or (not optimizable)
(> (length (slot-value gfun 'spec-list))
si::c-arguments-limit))
default-function)
;; Case 2*
((and (not (eq (slot-value (class-of gfun) 'name)
'standard-generic-function))
*clos-booted*)
t)
((null methods)
'standard-generic-function)
;; Cases 3*
((loop with class = (find-class 'standard-optimized-reader-method nil)
for m in methods
always (eq class (class-of m)))
'standard-optimized-reader-method)
((loop with class = (find-class 'standard-optimized-writer-method nil)
for m in methods
always (eq class (class-of m)))
'standard-optimized-writer-method)
;; Case 4*
(t
'standard-generic-function))))))
;;; ----------------------------------------------------------------------
;;; COMPUTE-APPLICABLE-METHODS
;;;
;;; This part is a source of problems because we have to access slots of
;;; various objects, which could potentially lead to infinite recursion as
;;; those accessors require also some dispatch. The solution is to avoid
;;; calling then generic function that implement the accessors.
;;; This is possible because:
;;; 1. The user can only extend compute-applicable-methods if it
;;; defines a method with a subclass of standard-generic-function
;;; 2. The user cannot extend slot-value and friends on standard-classes
;;; due to the restriction "Any method defined by a portable program
;;; on a specified generic function must have at least one specializer
;;; that is neither a specified class nor an eql specializer whose
;;; associated value is an instance of a specified class."
;;; 3. Subclasses of specified classes preserve the slot order in ECL.
;;;
(defun std-compute-applicable-methods (gf args)
(sort-applicable-methods gf (applicable-method-list gf args) args))
(setf (fdefinition 'compute-applicable-methods) #'std-compute-applicable-methods)
(defun applicable-method-list (gf args)
(declare (optimize (speed 3))
(si::c-local))
(with-early-accessors (+standard-method-slots+
+standard-generic-function-slots+
+eql-specializer-slots+
+standard-class-slots+)
(flet ((applicable-method-p (method args)
(loop for spec in (method-specializers method)
for arg in args
always (if (eql-specializer-flag spec)
(eql arg (eql-specializer-object spec))
(si::of-class-p arg spec)))))
(loop for method in (generic-function-methods gf)
when (applicable-method-p method args)
collect method))))
(defun std-compute-applicable-methods-using-classes (gf classes)
(declare (optimize (speed 3)))
(with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+)
(flet ((applicable-method-p (method classes)
(loop for spec in (method-specializers method)
for class in classes
always (cond ((eql-specializer-flag spec)
;; EQL specializer invalidate computation
;; we return NIL
(when (si::of-class-p (eql-specializer-object spec) class)
(return-from std-compute-applicable-methods-using-classes
(values nil nil)))
nil)
((si::subclassp class spec))))))
(values (sort-applicable-methods
gf
(loop for method in (generic-function-methods gf)
when (applicable-method-p method classes)
collect method)
classes)
t))))
(defun sort-applicable-methods (gf applicable-list args)
(declare (optimize (safety 0) (speed 3)))
(with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
(let ((f (generic-function-a-p-o-function gf))
(args-specializers (mapcar #'class-of args)))
;; reorder args to match the precedence order
(when f
(setf args-specializers
(funcall f (subseq args-specializers 0
(length (generic-function-argument-precedence-order gf))))))
;; then order the list
(do* ((scan applicable-list)
(most-specific (first scan) (first scan))
(ordered-list))
((null (cdr scan))
(when most-specific
;; at least one method
(nreverse
(push most-specific ordered-list))))
(dolist (meth (cdr scan))
(when (eq (compare-methods most-specific
meth args-specializers f) 2)
(setq most-specific meth)))
(setq scan (delete most-specific scan))
(push most-specific ordered-list)))))
(defun compare-methods (method-1 method-2 args-specializers f)
(declare (si::c-local))
(with-early-accessors (+standard-method-slots+)
(let* ((specializers-list-1 (method-specializers method-1))
(specializers-list-2 (method-specializers method-2)))
(compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
(if f (funcall f specializers-list-2) specializers-list-2)
args-specializers))))
(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
(declare (si::c-local))
(when (or spec-list-1 spec-list-2)
(ecase (compare-specializers (first spec-list-1)
(first spec-list-2)
(first args-specializers))
(1 '1)
(2 '2)
(=
(compare-specializers-lists (cdr spec-list-1)
(cdr spec-list-2)
(cdr args-specializers)))
((nil)
(error "The type specifiers ~S and ~S can not be disambiguated~
with respect to the argument specializer: ~S"
(or (car spec-list-1) t)
(or (car spec-list-2) t)
(car args-specializers)))))
)
(defun fast-subtypep (spec1 spec2)
(declare (si::c-local))
;; Specialized version of subtypep which uses the fact that spec1
;; and spec2 are either classes or of the form (EQL x)
(with-early-accessors (+eql-specializer-slots+ +standard-class-slots+)
(if (eql-specializer-flag spec1)
(if (eql-specializer-flag spec2)
(eql (eql-specializer-object spec1)
(eql-specializer-object spec2))
(si::of-class-p (eql-specializer-object spec1) spec2))
(if (eql-specializer-flag spec2)
;; There is only one class with a single element, which
;; is NULL = (MEMBER NIL).
(and (null (eql-specializer-object spec2))
(eq (class-name spec1) 'null))
(si::subclassp spec1 spec2)))))
(defun compare-specializers (spec-1 spec-2 arg-class)
(declare (si::c-local))
(with-early-accessors (+standard-class-slots+ +standard-class-slots+)
(let* ((cpl (class-precedence-list arg-class)))
(cond ((eq spec-1 spec-2) '=)
((fast-subtypep spec-1 spec-2) '1)
((fast-subtypep spec-2 spec-1) '2)
((eql-specializer-flag spec-1) '1) ; is this engough?
((eql-specializer-flag spec-2) '2) ; Beppe
((member spec-1 (member spec-2 cpl)) '2)
((member spec-2 (member spec-1 cpl)) '1)
;; This will force an error in the caller
(t nil)))))
(defun compute-g-f-spec-list (gf)
(with-early-accessors (+standard-generic-function-slots+
+eql-specializer-slots+
+standard-method-slots+)
(flet ((nupdate-spec-how-list (spec-how-list specializers gf)
;; update the spec-how of the gfun
;; computing the or of the previous value and the new one
(setf spec-how-list (or spec-how-list
(copy-list specializers)))
(do* ((l specializers (cdr l))
(l2 spec-how-list (cdr l2))
(spec-how)
(spec-how-old))
((null l))
(setq spec-how (first l) spec-how-old (first l2))
(setf (first l2)
(if (eql-specializer-flag spec-how)
(list* (eql-specializer-object spec-how)
(and (consp spec-how-old) spec-how-old))
(if (consp spec-how-old)
spec-how-old
spec-how))))
spec-how-list))
(let* ((spec-how-list nil)
(function nil)
(a-p-o (generic-function-argument-precedence-order gf)))
(dolist (method (generic-function-methods gf))
(setf spec-how-list
(nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
(setf (generic-function-spec-list gf)
(loop for type in spec-how-list
for i from 0
when type collect (cons type i)))
(let* ((g-f-l-l (generic-function-lambda-list gf)))
(when (consp g-f-l-l)
(let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
(unless (equal a-p-o required-arguments)
(setf function
(coerce `(lambda (%list)
(destructuring-bind ,required-arguments %list
(list ,@a-p-o)))
'function))))))
(setf (generic-function-a-p-o-function gf) function)
(si:clear-gfun-hash gf)))))
(defun print-object (object stream)
(print-unreadable-object (object stream)))