| 1 | ;;; clos.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003-2007 Peter Graves |
|---|
| 4 | ;;; $Id: clos.lisp 12758 2010-06-18 23:15:52Z astalla $ |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. |
|---|
| 19 | ;;; |
|---|
| 20 | ;;; As a special exception, the copyright holders of this library give you |
|---|
| 21 | ;;; permission to link this library with independent modules to produce an |
|---|
| 22 | ;;; executable, regardless of the license terms of these independent |
|---|
| 23 | ;;; modules, and to copy and distribute the resulting executable under |
|---|
| 24 | ;;; terms of your choice, provided that you also meet, for each linked |
|---|
| 25 | ;;; independent module, the terms and conditions of the license of that |
|---|
| 26 | ;;; module. An independent module is a module which is not derived from |
|---|
| 27 | ;;; or based on this library. If you modify this library, you may extend |
|---|
| 28 | ;;; this exception to your version of the library, but you are not |
|---|
| 29 | ;;; obligated to do so. If you do not wish to do so, delete this |
|---|
| 30 | ;;; exception statement from your version. |
|---|
| 31 | |
|---|
| 32 | ;;; Originally based on Closette. |
|---|
| 33 | |
|---|
| 34 | ;;; Closette Version 1.0 (February 10, 1991) |
|---|
| 35 | ;;; |
|---|
| 36 | ;;; Copyright (c) 1990, 1991 Xerox Corporation. |
|---|
| 37 | ;;; All rights reserved. |
|---|
| 38 | ;;; |
|---|
| 39 | ;;; Use and copying of this software and preparation of derivative works |
|---|
| 40 | ;;; based upon this software are permitted. Any distribution of this |
|---|
| 41 | ;;; software or derivative works must comply with all applicable United |
|---|
| 42 | ;;; States export control laws. |
|---|
| 43 | ;;; |
|---|
| 44 | ;;; This software is made available AS IS, and Xerox Corporation makes no |
|---|
| 45 | ;;; warranty about the software, its performance or its conformity to any |
|---|
| 46 | ;;; specification. |
|---|
| 47 | ;;; |
|---|
| 48 | ;;; Closette is an implementation of a subset of CLOS with a metaobject |
|---|
| 49 | ;;; protocol as described in "The Art of The Metaobject Protocol", |
|---|
| 50 | ;;; MIT Press, 1991. |
|---|
| 51 | |
|---|
| 52 | (in-package #:mop) |
|---|
| 53 | |
|---|
| 54 | (export '(class-precedence-list class-slots)) |
|---|
| 55 | (defconstant +the-standard-class+ (find-class 'standard-class)) |
|---|
| 56 | (defconstant +the-structure-class+ (find-class 'structure-class)) |
|---|
| 57 | (defconstant +the-standard-object-class+ (find-class 'standard-object)) |
|---|
| 58 | (defconstant +the-standard-method-class+ (find-class 'standard-method)) |
|---|
| 59 | (defconstant +the-standard-reader-method-class+ |
|---|
| 60 | (find-class 'standard-reader-method)) |
|---|
| 61 | (defconstant +the-standard-generic-function-class+ |
|---|
| 62 | (find-class 'standard-generic-function)) |
|---|
| 63 | (defconstant +the-T-class+ (find-class 'T)) |
|---|
| 64 | (defconstant +the-slot-definition-class+ (find-class 'slot-definition)) |
|---|
| 65 | (defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) |
|---|
| 66 | (defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) |
|---|
| 67 | |
|---|
| 68 | ;; Don't use DEFVAR, because that disallows loading clos.lisp |
|---|
| 69 | ;; after compiling it: the binding won't get assigned to T anymore |
|---|
| 70 | (defparameter *clos-booting* t) |
|---|
| 71 | |
|---|
| 72 | (defmacro define-class->%class-forwarder (name) |
|---|
| 73 | (let* (($name (if (consp name) (cadr name) name)) |
|---|
| 74 | (%name (intern (concatenate 'string |
|---|
| 75 | "%" |
|---|
| 76 | (if (consp name) |
|---|
| 77 | (symbol-name 'set-) "") |
|---|
| 78 | (symbol-name $name)) |
|---|
| 79 | (symbol-package $name)))) |
|---|
| 80 | `(progn |
|---|
| 81 | (declaim (notinline ,name)) |
|---|
| 82 | (defun ,name (&rest args) |
|---|
| 83 | (apply #',%name args))))) |
|---|
| 84 | |
|---|
| 85 | (define-class->%class-forwarder class-name) |
|---|
| 86 | (define-class->%class-forwarder (setf class-name)) |
|---|
| 87 | (define-class->%class-forwarder class-slots) |
|---|
| 88 | (define-class->%class-forwarder (setf class-slots)) |
|---|
| 89 | (define-class->%class-forwarder class-direct-slots) |
|---|
| 90 | (define-class->%class-forwarder (setf class-direct-slots)) |
|---|
| 91 | (define-class->%class-forwarder class-layout) |
|---|
| 92 | (define-class->%class-forwarder (setf class-layout)) |
|---|
| 93 | (define-class->%class-forwarder class-direct-superclasses) |
|---|
| 94 | (define-class->%class-forwarder (setf class-direct-superclasses)) |
|---|
| 95 | (define-class->%class-forwarder class-direct-subclasses) |
|---|
| 96 | (define-class->%class-forwarder (setf class-direct-subclasses)) |
|---|
| 97 | (define-class->%class-forwarder class-direct-methods) |
|---|
| 98 | (define-class->%class-forwarder (setf class-direct-methods)) |
|---|
| 99 | (define-class->%class-forwarder class-precedence-list) |
|---|
| 100 | (define-class->%class-forwarder (setf class-precedence-list)) |
|---|
| 101 | (define-class->%class-forwarder class-finalized-p) |
|---|
| 102 | (define-class->%class-forwarder (setf class-finalized-p)) |
|---|
| 103 | (define-class->%class-forwarder class-default-initargs) |
|---|
| 104 | (define-class->%class-forwarder (setf class-default-initargs)) |
|---|
| 105 | (define-class->%class-forwarder class-direct-default-initargs) |
|---|
| 106 | (define-class->%class-forwarder (setf class-direct-default-initargs)) |
|---|
| 107 | |
|---|
| 108 | (defun no-applicable-method (generic-function &rest args) |
|---|
| 109 | (error "There is no applicable method for the generic function ~S when called with arguments ~S." |
|---|
| 110 | generic-function |
|---|
| 111 | args)) |
|---|
| 112 | |
|---|
| 113 | |
|---|
| 114 | |
|---|
| 115 | (defmacro push-on-end (value location) |
|---|
| 116 | `(setf ,location (nconc ,location (list ,value)))) |
|---|
| 117 | |
|---|
| 118 | ;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list, |
|---|
| 119 | ;;; which must be non-nil. |
|---|
| 120 | |
|---|
| 121 | (defun (setf getf*) (new-value plist key) |
|---|
| 122 | (block body |
|---|
| 123 | (do ((x plist (cddr x))) |
|---|
| 124 | ((null x)) |
|---|
| 125 | (when (eq (car x) key) |
|---|
| 126 | (setf (car (cdr x)) new-value) |
|---|
| 127 | (return-from body new-value))) |
|---|
| 128 | (push-on-end key plist) |
|---|
| 129 | (push-on-end new-value plist) |
|---|
| 130 | new-value)) |
|---|
| 131 | |
|---|
| 132 | (defun mapappend (fun &rest args) |
|---|
| 133 | (if (some #'null args) |
|---|
| 134 | () |
|---|
| 135 | (append (apply fun (mapcar #'car args)) |
|---|
| 136 | (apply #'mapappend fun (mapcar #'cdr args))))) |
|---|
| 137 | |
|---|
| 138 | (defun mapplist (fun x) |
|---|
| 139 | (if (null x) |
|---|
| 140 | () |
|---|
| 141 | (cons (funcall fun (car x) (cadr x)) |
|---|
| 142 | (mapplist fun (cddr x))))) |
|---|
| 143 | |
|---|
| 144 | (defsetf std-instance-layout %set-std-instance-layout) |
|---|
| 145 | (defsetf standard-instance-access %set-standard-instance-access) |
|---|
| 146 | |
|---|
| 147 | (defun (setf find-class) (new-value symbol &optional errorp environment) |
|---|
| 148 | (declare (ignore errorp environment)) |
|---|
| 149 | (%set-find-class symbol new-value)) |
|---|
| 150 | |
|---|
| 151 | (defun canonicalize-direct-slots (direct-slots) |
|---|
| 152 | `(list ,@(mapcar #'canonicalize-direct-slot direct-slots))) |
|---|
| 153 | |
|---|
| 154 | (defun canonicalize-direct-slot (spec) |
|---|
| 155 | (if (symbolp spec) |
|---|
| 156 | `(list :name ',spec) |
|---|
| 157 | (let ((name (car spec)) |
|---|
| 158 | (initfunction nil) |
|---|
| 159 | (initform nil) |
|---|
| 160 | (initargs ()) |
|---|
| 161 | (type nil) |
|---|
| 162 | (allocation nil) |
|---|
| 163 | (documentation nil) |
|---|
| 164 | (readers ()) |
|---|
| 165 | (writers ()) |
|---|
| 166 | (other-options ()) |
|---|
| 167 | (non-std-options ())) |
|---|
| 168 | (do ((olist (cdr spec) (cddr olist))) |
|---|
| 169 | ((null olist)) |
|---|
| 170 | (case (car olist) |
|---|
| 171 | (:initform |
|---|
| 172 | (when initform |
|---|
| 173 | (error 'program-error |
|---|
| 174 | "duplicate slot option :INITFORM for slot named ~S" |
|---|
| 175 | name)) |
|---|
| 176 | (setq initfunction |
|---|
| 177 | `(function (lambda () ,(cadr olist)))) |
|---|
| 178 | (setq initform `',(cadr olist))) |
|---|
| 179 | (:initarg |
|---|
| 180 | (push-on-end (cadr olist) initargs)) |
|---|
| 181 | (:allocation |
|---|
| 182 | (when allocation |
|---|
| 183 | (error 'program-error |
|---|
| 184 | "duplicate slot option :ALLOCATION for slot named ~S" |
|---|
| 185 | name)) |
|---|
| 186 | (setf allocation (cadr olist)) |
|---|
| 187 | (push-on-end (car olist) other-options) |
|---|
| 188 | (push-on-end (cadr olist) other-options)) |
|---|
| 189 | (:type |
|---|
| 190 | (when type |
|---|
| 191 | (error 'program-error |
|---|
| 192 | "duplicate slot option :TYPE for slot named ~S" |
|---|
| 193 | name)) |
|---|
| 194 | (setf type (cadr olist))) ;; FIXME type is ignored |
|---|
| 195 | (:documentation |
|---|
| 196 | (when documentation |
|---|
| 197 | (error 'program-error |
|---|
| 198 | "duplicate slot option :DOCUMENTATION for slot named ~S" |
|---|
| 199 | name)) |
|---|
| 200 | (setf documentation (cadr olist))) ;; FIXME documentation is ignored |
|---|
| 201 | (:reader |
|---|
| 202 | (maybe-note-name-defined (cadr olist)) |
|---|
| 203 | (push-on-end (cadr olist) readers)) |
|---|
| 204 | (:writer |
|---|
| 205 | (maybe-note-name-defined (cadr olist)) |
|---|
| 206 | (push-on-end (cadr olist) writers)) |
|---|
| 207 | (:accessor |
|---|
| 208 | (maybe-note-name-defined (cadr olist)) |
|---|
| 209 | (push-on-end (cadr olist) readers) |
|---|
| 210 | (push-on-end `(setf ,(cadr olist)) writers)) |
|---|
| 211 | (t |
|---|
| 212 | (push-on-end (car olist) non-std-options) |
|---|
| 213 | (push-on-end (cadr olist) non-std-options)))) |
|---|
| 214 | ; (error 'program-error |
|---|
| 215 | ; "invalid initialization argument ~S for slot named ~S" |
|---|
| 216 | ; (car olist) name)) |
|---|
| 217 | `(list |
|---|
| 218 | :name ',name |
|---|
| 219 | ,@(when initfunction |
|---|
| 220 | `(:initform ,initform |
|---|
| 221 | :initfunction ,initfunction)) |
|---|
| 222 | ,@(when initargs `(:initargs ',initargs)) |
|---|
| 223 | ,@(when readers `(:readers ',readers)) |
|---|
| 224 | ,@(when writers `(:writers ',writers)) |
|---|
| 225 | ,@other-options |
|---|
| 226 | ,@non-std-options)))) |
|---|
| 227 | |
|---|
| 228 | (defun maybe-note-name-defined (name) |
|---|
| 229 | (when (fboundp 'note-name-defined) |
|---|
| 230 | (note-name-defined name))) |
|---|
| 231 | |
|---|
| 232 | (defun canonicalize-direct-superclasses (direct-superclasses) |
|---|
| 233 | (let ((classes '())) |
|---|
| 234 | (dolist (class-specifier direct-superclasses) |
|---|
| 235 | (if (classp class-specifier) |
|---|
| 236 | (push class-specifier classes) |
|---|
| 237 | (let ((class (find-class class-specifier nil))) |
|---|
| 238 | (unless class |
|---|
| 239 | (setf class (make-forward-referenced-class class-specifier))) |
|---|
| 240 | (push class classes)))) |
|---|
| 241 | (nreverse classes))) |
|---|
| 242 | |
|---|
| 243 | (defun canonicalize-defclass-options (options) |
|---|
| 244 | (mapappend #'canonicalize-defclass-option options)) |
|---|
| 245 | |
|---|
| 246 | (defun canonicalize-defclass-option (option) |
|---|
| 247 | (case (car option) |
|---|
| 248 | (:metaclass |
|---|
| 249 | (list ':metaclass |
|---|
| 250 | `(find-class ',(cadr option)))) |
|---|
| 251 | (:default-initargs |
|---|
| 252 | (list |
|---|
| 253 | ':direct-default-initargs |
|---|
| 254 | `(list ,@(mapappend |
|---|
| 255 | #'(lambda (x) x) |
|---|
| 256 | (mapplist |
|---|
| 257 | #'(lambda (key value) |
|---|
| 258 | `(',key ,(make-initfunction value))) |
|---|
| 259 | (cdr option)))))) |
|---|
| 260 | ((:documentation :report) |
|---|
| 261 | (list (car option) `',(cadr option))) |
|---|
| 262 | (t (list (car option) `(quote ,(cdr option)))))) |
|---|
| 263 | ; (error 'program-error |
|---|
| 264 | ; :format-control "invalid DEFCLASS option ~S" |
|---|
| 265 | ; :format-arguments (list (car option)))))) |
|---|
| 266 | |
|---|
| 267 | (defun make-initfunction (initform) |
|---|
| 268 | `(function (lambda () ,initform))) |
|---|
| 269 | |
|---|
| 270 | (defun slot-definition-allocation (slot-definition) |
|---|
| 271 | (%slot-definition-allocation slot-definition)) |
|---|
| 272 | |
|---|
| 273 | (declaim (notinline (setf slot-definition-allocation))) |
|---|
| 274 | (defun (setf slot-definition-allocation) (value slot-definition) |
|---|
| 275 | (set-slot-definition-allocation slot-definition value)) |
|---|
| 276 | |
|---|
| 277 | (defun slot-definition-initargs (slot-definition) |
|---|
| 278 | (%slot-definition-initargs slot-definition)) |
|---|
| 279 | |
|---|
| 280 | (declaim (notinline (setf slot-definition-initargs))) |
|---|
| 281 | (defun (setf slot-definition-initargs) (value slot-definition) |
|---|
| 282 | (set-slot-definition-initargs slot-definition value)) |
|---|
| 283 | |
|---|
| 284 | (defun slot-definition-initform (slot-definition) |
|---|
| 285 | (%slot-definition-initform slot-definition)) |
|---|
| 286 | |
|---|
| 287 | (declaim (notinline (setf slot-definition-initform))) |
|---|
| 288 | (defun (setf slot-definition-initform) (value slot-definition) |
|---|
| 289 | (set-slot-definition-initform slot-definition value)) |
|---|
| 290 | |
|---|
| 291 | (defun slot-definition-initfunction (slot-definition) |
|---|
| 292 | (%slot-definition-initfunction slot-definition)) |
|---|
| 293 | |
|---|
| 294 | (declaim (notinline (setf slot-definition-initfunction))) |
|---|
| 295 | (defun (setf slot-definition-initfunction) (value slot-definition) |
|---|
| 296 | (set-slot-definition-initfunction slot-definition value)) |
|---|
| 297 | |
|---|
| 298 | (defun slot-definition-name (slot-definition) |
|---|
| 299 | (%slot-definition-name slot-definition)) |
|---|
| 300 | |
|---|
| 301 | (declaim (notinline (setf slot-definition-name))) |
|---|
| 302 | (defun (setf slot-definition-name) (value slot-definition) |
|---|
| 303 | (set-slot-definition-name slot-definition value)) |
|---|
| 304 | |
|---|
| 305 | (defun slot-definition-readers (slot-definition) |
|---|
| 306 | (%slot-definition-readers slot-definition)) |
|---|
| 307 | |
|---|
| 308 | (declaim (notinline (setf slot-definition-readers))) |
|---|
| 309 | (defun (setf slot-definition-readers) (value slot-definition) |
|---|
| 310 | (set-slot-definition-readers slot-definition value)) |
|---|
| 311 | |
|---|
| 312 | (defun slot-definition-writers (slot-definition) |
|---|
| 313 | (%slot-definition-writers slot-definition)) |
|---|
| 314 | |
|---|
| 315 | (declaim (notinline (setf slot-definition-writers))) |
|---|
| 316 | (defun (setf slot-definition-writers) (value slot-definition) |
|---|
| 317 | (set-slot-definition-writers slot-definition value)) |
|---|
| 318 | |
|---|
| 319 | (defun slot-definition-allocation-class (slot-definition) |
|---|
| 320 | (%slot-definition-allocation-class slot-definition)) |
|---|
| 321 | |
|---|
| 322 | (declaim (notinline (setf slot-definition-allocation-class))) |
|---|
| 323 | (defun (setf slot-definition-allocation-class) (value slot-definition) |
|---|
| 324 | (set-slot-definition-allocation-class slot-definition value)) |
|---|
| 325 | |
|---|
| 326 | (defun slot-definition-location (slot-definition) |
|---|
| 327 | (%slot-definition-location slot-definition)) |
|---|
| 328 | |
|---|
| 329 | (declaim (notinline (setf slot-definition-location-class))) |
|---|
| 330 | (defun (setf slot-definition-location) (value slot-definition) |
|---|
| 331 | (set-slot-definition-location slot-definition value)) |
|---|
| 332 | |
|---|
| 333 | (defun init-slot-definition (slot &key name |
|---|
| 334 | (initargs ()) |
|---|
| 335 | (initform nil) |
|---|
| 336 | (initfunction nil) |
|---|
| 337 | (readers ()) |
|---|
| 338 | (writers ()) |
|---|
| 339 | (allocation :instance) |
|---|
| 340 | (allocation-class nil) |
|---|
| 341 | &allow-other-keys) |
|---|
| 342 | (setf (slot-definition-name slot) name) |
|---|
| 343 | (setf (slot-definition-initargs slot) initargs) |
|---|
| 344 | (setf (slot-definition-initform slot) initform) |
|---|
| 345 | (setf (slot-definition-initfunction slot) initfunction) |
|---|
| 346 | (setf (slot-definition-readers slot) readers) |
|---|
| 347 | (setf (slot-definition-writers slot) writers) |
|---|
| 348 | (setf (slot-definition-allocation slot) allocation) |
|---|
| 349 | (setf (slot-definition-allocation-class slot) allocation-class) |
|---|
| 350 | slot) |
|---|
| 351 | |
|---|
| 352 | (defun make-direct-slot-definition (class &rest args) |
|---|
| 353 | (let ((slot-class (direct-slot-definition-class class))) |
|---|
| 354 | (if (eq slot-class +the-direct-slot-definition-class+) |
|---|
| 355 | (let ((slot (make-slot-definition +the-direct-slot-definition-class+))) |
|---|
| 356 | (apply #'init-slot-definition slot :allocation-class class args) |
|---|
| 357 | slot) |
|---|
| 358 | (progn |
|---|
| 359 | (let ((slot (apply #'make-instance slot-class :allocation-class class |
|---|
| 360 | args))) |
|---|
| 361 | slot))))) |
|---|
| 362 | |
|---|
| 363 | (defun make-effective-slot-definition (class &rest args) |
|---|
| 364 | (let ((slot-class (effective-slot-definition-class class))) |
|---|
| 365 | (if (eq slot-class +the-effective-slot-definition-class+) |
|---|
| 366 | (let ((slot (make-slot-definition +the-effective-slot-definition-class+))) |
|---|
| 367 | (apply #'init-slot-definition slot args) |
|---|
| 368 | slot) |
|---|
| 369 | (progn |
|---|
| 370 | (let ((slot (apply #'make-instance slot-class args))) |
|---|
| 371 | slot))))) |
|---|
| 372 | |
|---|
| 373 | ;;; finalize-inheritance |
|---|
| 374 | |
|---|
| 375 | (defun std-compute-class-default-initargs (class) |
|---|
| 376 | (mapcan #'(lambda (c) |
|---|
| 377 | (copy-list |
|---|
| 378 | (class-direct-default-initargs c))) |
|---|
| 379 | (class-precedence-list class))) |
|---|
| 380 | |
|---|
| 381 | (defun std-finalize-inheritance (class) |
|---|
| 382 | (setf (class-precedence-list class) |
|---|
| 383 | (funcall (if (eq (class-of class) +the-standard-class+) |
|---|
| 384 | #'std-compute-class-precedence-list |
|---|
| 385 | #'compute-class-precedence-list) |
|---|
| 386 | class)) |
|---|
| 387 | (dolist (class (class-precedence-list class)) |
|---|
| 388 | (when (typep class 'forward-referenced-class) |
|---|
| 389 | (return-from std-finalize-inheritance))) |
|---|
| 390 | (setf (class-slots class) |
|---|
| 391 | (funcall (if (eq (class-of class) +the-standard-class+) |
|---|
| 392 | #'std-compute-slots |
|---|
| 393 | #'compute-slots) class)) |
|---|
| 394 | (let ((old-layout (class-layout class)) |
|---|
| 395 | (length 0) |
|---|
| 396 | (instance-slots '()) |
|---|
| 397 | (shared-slots '())) |
|---|
| 398 | (dolist (slot (class-slots class)) |
|---|
| 399 | (case (slot-definition-allocation slot) |
|---|
| 400 | (:instance |
|---|
| 401 | (setf (slot-definition-location slot) length) |
|---|
| 402 | (incf length) |
|---|
| 403 | (push (slot-definition-name slot) instance-slots)) |
|---|
| 404 | (:class |
|---|
| 405 | (unless (slot-definition-location slot) |
|---|
| 406 | (let ((allocation-class (slot-definition-allocation-class slot))) |
|---|
| 407 | (setf (slot-definition-location slot) |
|---|
| 408 | (if (eq allocation-class class) |
|---|
| 409 | (cons (slot-definition-name slot) +slot-unbound+) |
|---|
| 410 | (slot-location allocation-class (slot-definition-name slot)))))) |
|---|
| 411 | (push (slot-definition-location slot) shared-slots)))) |
|---|
| 412 | (when old-layout |
|---|
| 413 | ;; Redefined class: initialize added shared slots. |
|---|
| 414 | (dolist (location shared-slots) |
|---|
| 415 | (let* ((slot-name (car location)) |
|---|
| 416 | (old-location (layout-slot-location old-layout slot-name))) |
|---|
| 417 | (unless old-location |
|---|
| 418 | (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name)) |
|---|
| 419 | (initfunction (slot-definition-initfunction slot-definition))) |
|---|
| 420 | (when initfunction |
|---|
| 421 | (setf (cdr location) (funcall initfunction)))))))) |
|---|
| 422 | (setf (class-layout class) |
|---|
| 423 | (make-layout class (nreverse instance-slots) (nreverse shared-slots)))) |
|---|
| 424 | (setf (class-default-initargs class) |
|---|
| 425 | (std-compute-class-default-initargs class)) |
|---|
| 426 | (setf (class-finalized-p class) t)) |
|---|
| 427 | |
|---|
| 428 | ;;; Class precedence lists |
|---|
| 429 | |
|---|
| 430 | (defun std-compute-class-precedence-list (class) |
|---|
| 431 | (let ((classes-to-order (collect-superclasses* class))) |
|---|
| 432 | (topological-sort classes-to-order |
|---|
| 433 | (remove-duplicates |
|---|
| 434 | (mapappend #'local-precedence-ordering |
|---|
| 435 | classes-to-order)) |
|---|
| 436 | #'std-tie-breaker-rule))) |
|---|
| 437 | |
|---|
| 438 | ;;; topological-sort implements the standard algorithm for topologically |
|---|
| 439 | ;;; sorting an arbitrary set of elements while honoring the precedence |
|---|
| 440 | ;;; constraints given by a set of (X,Y) pairs that indicate that element |
|---|
| 441 | ;;; X must precede element Y. The tie-breaker procedure is called when it |
|---|
| 442 | ;;; is necessary to choose from multiple minimal elements; both a list of |
|---|
| 443 | ;;; candidates and the ordering so far are provided as arguments. |
|---|
| 444 | |
|---|
| 445 | (defun topological-sort (elements constraints tie-breaker) |
|---|
| 446 | (let ((remaining-constraints constraints) |
|---|
| 447 | (remaining-elements elements) |
|---|
| 448 | (result ())) |
|---|
| 449 | (loop |
|---|
| 450 | (let ((minimal-elements |
|---|
| 451 | (remove-if |
|---|
| 452 | #'(lambda (class) |
|---|
| 453 | (member class remaining-constraints |
|---|
| 454 | :key #'cadr)) |
|---|
| 455 | remaining-elements))) |
|---|
| 456 | (when (null minimal-elements) |
|---|
| 457 | (if (null remaining-elements) |
|---|
| 458 | (return-from topological-sort result) |
|---|
| 459 | (error "Inconsistent precedence graph."))) |
|---|
| 460 | (let ((choice (if (null (cdr minimal-elements)) |
|---|
| 461 | (car minimal-elements) |
|---|
| 462 | (funcall tie-breaker |
|---|
| 463 | minimal-elements |
|---|
| 464 | result)))) |
|---|
| 465 | (setq result (append result (list choice))) |
|---|
| 466 | (setq remaining-elements |
|---|
| 467 | (remove choice remaining-elements)) |
|---|
| 468 | (setq remaining-constraints |
|---|
| 469 | (remove choice |
|---|
| 470 | remaining-constraints |
|---|
| 471 | :test #'member))))))) |
|---|
| 472 | |
|---|
| 473 | ;;; In the event of a tie while topologically sorting class precedence lists, |
|---|
| 474 | ;;; the CLOS Specification says to "select the one that has a direct subclass |
|---|
| 475 | ;;; rightmost in the class precedence list computed so far." The same result |
|---|
| 476 | ;;; is obtained by inspecting the partially constructed class precedence list |
|---|
| 477 | ;;; from right to left, looking for the first minimal element to show up among |
|---|
| 478 | ;;; the direct superclasses of the class precedence list constituent. |
|---|
| 479 | ;;; (There's a lemma that shows that this rule yields a unique result.) |
|---|
| 480 | |
|---|
| 481 | (defun std-tie-breaker-rule (minimal-elements cpl-so-far) |
|---|
| 482 | (dolist (cpl-constituent (reverse cpl-so-far)) |
|---|
| 483 | (let* ((supers (class-direct-superclasses cpl-constituent)) |
|---|
| 484 | (common (intersection minimal-elements supers))) |
|---|
| 485 | (when (not (null common)) |
|---|
| 486 | (return-from std-tie-breaker-rule (car common)))))) |
|---|
| 487 | |
|---|
| 488 | ;;; This version of collect-superclasses* isn't bothered by cycles in the class |
|---|
| 489 | ;;; hierarchy, which sometimes happen by accident. |
|---|
| 490 | |
|---|
| 491 | (defun collect-superclasses* (class) |
|---|
| 492 | (labels ((all-superclasses-loop (seen superclasses) |
|---|
| 493 | (let ((to-be-processed |
|---|
| 494 | (set-difference superclasses seen))) |
|---|
| 495 | (if (null to-be-processed) |
|---|
| 496 | superclasses |
|---|
| 497 | (let ((class-to-process |
|---|
| 498 | (car to-be-processed))) |
|---|
| 499 | (all-superclasses-loop |
|---|
| 500 | (cons class-to-process seen) |
|---|
| 501 | (union (class-direct-superclasses |
|---|
| 502 | class-to-process) |
|---|
| 503 | superclasses))))))) |
|---|
| 504 | (all-superclasses-loop () (list class)))) |
|---|
| 505 | |
|---|
| 506 | ;;; The local precedence ordering of a class C with direct superclasses C_1, |
|---|
| 507 | ;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). |
|---|
| 508 | |
|---|
| 509 | (defun local-precedence-ordering (class) |
|---|
| 510 | (mapcar #'list |
|---|
| 511 | (cons class |
|---|
| 512 | (butlast (class-direct-superclasses class))) |
|---|
| 513 | (class-direct-superclasses class))) |
|---|
| 514 | |
|---|
| 515 | ;;; Slot inheritance |
|---|
| 516 | |
|---|
| 517 | (defun std-compute-slots (class) |
|---|
| 518 | (let* ((all-slots (mapappend #'class-direct-slots |
|---|
| 519 | (class-precedence-list class))) |
|---|
| 520 | (all-names (remove-duplicates |
|---|
| 521 | (mapcar 'slot-definition-name all-slots)))) |
|---|
| 522 | (mapcar #'(lambda (name) |
|---|
| 523 | (funcall |
|---|
| 524 | (if (eq (class-of class) +the-standard-class+) |
|---|
| 525 | #'std-compute-effective-slot-definition |
|---|
| 526 | #'compute-effective-slot-definition) |
|---|
| 527 | class |
|---|
| 528 | (remove name all-slots |
|---|
| 529 | :key 'slot-definition-name |
|---|
| 530 | :test-not #'eq))) |
|---|
| 531 | all-names))) |
|---|
| 532 | |
|---|
| 533 | (defun std-compute-effective-slot-definition (class direct-slots) |
|---|
| 534 | (let ((initer (find-if-not #'null direct-slots |
|---|
| 535 | :key 'slot-definition-initfunction))) |
|---|
| 536 | (make-effective-slot-definition |
|---|
| 537 | class |
|---|
| 538 | :name (slot-definition-name (car direct-slots)) |
|---|
| 539 | :initform (if initer |
|---|
| 540 | (slot-definition-initform initer) |
|---|
| 541 | nil) |
|---|
| 542 | :initfunction (if initer |
|---|
| 543 | (slot-definition-initfunction initer) |
|---|
| 544 | nil) |
|---|
| 545 | :initargs (remove-duplicates |
|---|
| 546 | (mapappend 'slot-definition-initargs |
|---|
| 547 | direct-slots)) |
|---|
| 548 | :allocation (slot-definition-allocation (car direct-slots)) |
|---|
| 549 | :allocation-class (when (slot-boundp (car direct-slots) |
|---|
| 550 | 'sys::allocation-class) |
|---|
| 551 | ;;for some classes created in Java |
|---|
| 552 | ;;(e.g. SimpleCondition) this slot is unbound |
|---|
| 553 | (slot-definition-allocation-class (car direct-slots)))))) |
|---|
| 554 | |
|---|
| 555 | ;;; Standard instance slot access |
|---|
| 556 | |
|---|
| 557 | ;;; N.B. The location of the effective-slots slots in the class metaobject for |
|---|
| 558 | ;;; standard-class must be determined without making any further slot |
|---|
| 559 | ;;; references. |
|---|
| 560 | |
|---|
| 561 | (defun find-slot-definition (class slot-name) |
|---|
| 562 | (dolist (slot (class-slots class) nil) |
|---|
| 563 | (when (eq slot-name (slot-definition-name slot)) |
|---|
| 564 | (return slot)))) |
|---|
| 565 | |
|---|
| 566 | (defun slot-location (class slot-name) |
|---|
| 567 | (let ((slot (find-slot-definition class slot-name))) |
|---|
| 568 | (if slot |
|---|
| 569 | (slot-definition-location slot) |
|---|
| 570 | nil))) |
|---|
| 571 | |
|---|
| 572 | (defun instance-slot-location (instance slot-name) |
|---|
| 573 | (let ((layout (std-instance-layout instance))) |
|---|
| 574 | (and layout (layout-slot-location layout slot-name)))) |
|---|
| 575 | |
|---|
| 576 | (defun slot-value (object slot-name) |
|---|
| 577 | (if (or (eq (class-of (class-of object)) +the-standard-class+) |
|---|
| 578 | (eq (class-of (class-of object)) +the-structure-class+)) |
|---|
| 579 | (std-slot-value object slot-name) |
|---|
| 580 | (slot-value-using-class (class-of object) object slot-name))) |
|---|
| 581 | |
|---|
| 582 | (defsetf std-slot-value set-std-slot-value) |
|---|
| 583 | |
|---|
| 584 | (defun %set-slot-value (object slot-name new-value) |
|---|
| 585 | (if (or (eq (class-of (class-of object)) +the-standard-class+) |
|---|
| 586 | (eq (class-of (class-of object)) +the-structure-class+)) |
|---|
| 587 | (setf (std-slot-value object slot-name) new-value) |
|---|
| 588 | (set-slot-value-using-class new-value (class-of object) |
|---|
| 589 | object slot-name))) |
|---|
| 590 | |
|---|
| 591 | (defsetf slot-value %set-slot-value) |
|---|
| 592 | |
|---|
| 593 | (defun slot-boundp (object slot-name) |
|---|
| 594 | (if (eq (class-of (class-of object)) +the-standard-class+) |
|---|
| 595 | (std-slot-boundp object slot-name) |
|---|
| 596 | (slot-boundp-using-class (class-of object) object slot-name))) |
|---|
| 597 | |
|---|
| 598 | (defun std-slot-makunbound (instance slot-name) |
|---|
| 599 | (let ((location (instance-slot-location instance slot-name))) |
|---|
| 600 | (cond ((fixnump location) |
|---|
| 601 | (setf (standard-instance-access instance location) +slot-unbound+)) |
|---|
| 602 | ((consp location) |
|---|
| 603 | (setf (cdr location) +slot-unbound+)) |
|---|
| 604 | (t |
|---|
| 605 | (slot-missing (class-of instance) instance slot-name 'slot-makunbound)))) |
|---|
| 606 | instance) |
|---|
| 607 | |
|---|
| 608 | (defun slot-makunbound (object slot-name) |
|---|
| 609 | (if (eq (class-of (class-of object)) +the-standard-class+) |
|---|
| 610 | (std-slot-makunbound object slot-name) |
|---|
| 611 | (slot-makunbound-using-class (class-of object) object slot-name))) |
|---|
| 612 | |
|---|
| 613 | (defun std-slot-exists-p (instance slot-name) |
|---|
| 614 | (not (null (find slot-name (class-slots (class-of instance)) |
|---|
| 615 | :key 'slot-definition-name)))) |
|---|
| 616 | |
|---|
| 617 | (defun slot-exists-p (object slot-name) |
|---|
| 618 | (if (eq (class-of (class-of object)) +the-standard-class+) |
|---|
| 619 | (std-slot-exists-p object slot-name) |
|---|
| 620 | (slot-exists-p-using-class (class-of object) object slot-name))) |
|---|
| 621 | |
|---|
| 622 | (defun instance-slot-p (slot) |
|---|
| 623 | (eq (slot-definition-allocation slot) :instance)) |
|---|
| 624 | |
|---|
| 625 | (defun make-instance-standard-class (metaclass |
|---|
| 626 | &rest initargs |
|---|
| 627 | &key name direct-superclasses direct-slots |
|---|
| 628 | direct-default-initargs |
|---|
| 629 | documentation) |
|---|
| 630 | (declare (ignore metaclass)) |
|---|
| 631 | (let ((class (std-allocate-instance +the-standard-class+))) |
|---|
| 632 | (check-initargs class t initargs) |
|---|
| 633 | (%set-class-name name class) |
|---|
| 634 | (%set-class-layout nil class) |
|---|
| 635 | (%set-class-direct-subclasses () class) |
|---|
| 636 | (%set-class-direct-methods () class) |
|---|
| 637 | (%set-class-documentation class documentation) |
|---|
| 638 | (std-after-initialization-for-classes class |
|---|
| 639 | :direct-superclasses direct-superclasses |
|---|
| 640 | :direct-slots direct-slots |
|---|
| 641 | :direct-default-initargs direct-default-initargs) |
|---|
| 642 | class)) |
|---|
| 643 | |
|---|
| 644 | ;(defun convert-to-direct-slot-definition (class canonicalized-slot) |
|---|
| 645 | ; (apply #'make-instance |
|---|
| 646 | ; (apply #'direct-slot-definition-class |
|---|
| 647 | ; class canonicalized-slot) |
|---|
| 648 | ; canonicalized-slot)) |
|---|
| 649 | |
|---|
| 650 | (defun std-after-initialization-for-classes (class |
|---|
| 651 | &key direct-superclasses direct-slots |
|---|
| 652 | direct-default-initargs |
|---|
| 653 | &allow-other-keys) |
|---|
| 654 | (let ((supers (or direct-superclasses |
|---|
| 655 | (list +the-standard-object-class+)))) |
|---|
| 656 | (setf (class-direct-superclasses class) supers) |
|---|
| 657 | (dolist (superclass supers) |
|---|
| 658 | (pushnew class (class-direct-subclasses superclass)))) |
|---|
| 659 | (let ((slots (mapcar #'(lambda (slot-properties) |
|---|
| 660 | (apply #'make-direct-slot-definition class slot-properties)) |
|---|
| 661 | direct-slots))) |
|---|
| 662 | (setf (class-direct-slots class) slots) |
|---|
| 663 | (dolist (direct-slot slots) |
|---|
| 664 | (dolist (reader (slot-definition-readers direct-slot)) |
|---|
| 665 | (add-reader-method class reader (slot-definition-name direct-slot))) |
|---|
| 666 | (dolist (writer (slot-definition-writers direct-slot)) |
|---|
| 667 | (add-writer-method class writer (slot-definition-name direct-slot))))) |
|---|
| 668 | (setf (class-direct-default-initargs class) direct-default-initargs) |
|---|
| 669 | (funcall (if (eq (class-of class) +the-standard-class+) |
|---|
| 670 | #'std-finalize-inheritance |
|---|
| 671 | #'finalize-inheritance) |
|---|
| 672 | class) |
|---|
| 673 | (values)) |
|---|
| 674 | |
|---|
| 675 | (defun canonical-slot-name (canonical-slot) |
|---|
| 676 | (getf canonical-slot :name)) |
|---|
| 677 | |
|---|
| 678 | (defvar *extensible-built-in-classes* |
|---|
| 679 | (list (find-class 'sequence) |
|---|
| 680 | (find-class 'java:java-object))) |
|---|
| 681 | |
|---|
| 682 | (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) |
|---|
| 683 | ;; Check for duplicate slots. |
|---|
| 684 | (remf all-keys :metaclass) |
|---|
| 685 | (let ((slots (getf all-keys :direct-slots))) |
|---|
| 686 | (dolist (s1 slots) |
|---|
| 687 | (let ((name1 (canonical-slot-name s1))) |
|---|
| 688 | (dolist (s2 (cdr (memq s1 slots))) |
|---|
| 689 | (when (eq name1 (canonical-slot-name s2)) |
|---|
| 690 | (error 'program-error "Duplicate slot ~S" name1)))))) |
|---|
| 691 | ;; Check for duplicate argument names in :DEFAULT-INITARGS. |
|---|
| 692 | (let ((names ())) |
|---|
| 693 | (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs)) |
|---|
| 694 | (name (car initargs) (car initargs))) |
|---|
| 695 | ((null initargs)) |
|---|
| 696 | (push name names)) |
|---|
| 697 | (do* ((names names (cdr names)) |
|---|
| 698 | (name (car names) (car names))) |
|---|
| 699 | ((null names)) |
|---|
| 700 | (when (memq name (cdr names)) |
|---|
| 701 | (error 'program-error |
|---|
| 702 | :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." |
|---|
| 703 | :format-arguments (list name))))) |
|---|
| 704 | (let ((direct-superclasses (getf all-keys :direct-superclasses))) |
|---|
| 705 | (dolist (class direct-superclasses) |
|---|
| 706 | (when (and (typep class 'built-in-class) |
|---|
| 707 | (not (member class *extensible-built-in-classes*))) |
|---|
| 708 | (error "Attempt to define a subclass of a built-in-class: ~S" class)))) |
|---|
| 709 | (let ((old-class (find-class name nil))) |
|---|
| 710 | (cond ((and old-class (eq name (class-name old-class))) |
|---|
| 711 | (cond ((typep old-class 'built-in-class) |
|---|
| 712 | (error "The symbol ~S names a built-in class." name)) |
|---|
| 713 | ((typep old-class 'forward-referenced-class) |
|---|
| 714 | (let ((new-class (apply #'make-instance-standard-class |
|---|
| 715 | +the-standard-class+ |
|---|
| 716 | :name name all-keys))) |
|---|
| 717 | (%set-find-class name new-class) |
|---|
| 718 | (dolist (subclass (class-direct-subclasses old-class)) |
|---|
| 719 | (setf (class-direct-superclasses subclass) |
|---|
| 720 | (substitute new-class old-class |
|---|
| 721 | (class-direct-superclasses subclass)))) |
|---|
| 722 | new-class)) |
|---|
| 723 | (t |
|---|
| 724 | ;; We're redefining the class. |
|---|
| 725 | (%make-instances-obsolete old-class) |
|---|
| 726 | (check-initargs old-class t all-keys) |
|---|
| 727 | (apply #'std-after-initialization-for-classes old-class all-keys) |
|---|
| 728 | old-class))) |
|---|
| 729 | (t |
|---|
| 730 | (let ((class (apply (if metaclass |
|---|
| 731 | #'make-instance |
|---|
| 732 | #'make-instance-standard-class) |
|---|
| 733 | (or metaclass |
|---|
| 734 | +the-standard-class+) |
|---|
| 735 | :name name all-keys))) |
|---|
| 736 | (%set-find-class name class) |
|---|
| 737 | class))))) |
|---|
| 738 | |
|---|
| 739 | (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) |
|---|
| 740 | (unless (>= (length form) 3) |
|---|
| 741 | (error 'program-error "Wrong number of arguments for DEFCLASS.")) |
|---|
| 742 | (check-declaration-type name) |
|---|
| 743 | `(ensure-class ',name |
|---|
| 744 | :direct-superclasses |
|---|
| 745 | (canonicalize-direct-superclasses ',direct-superclasses) |
|---|
| 746 | :direct-slots |
|---|
| 747 | ,(canonicalize-direct-slots direct-slots) |
|---|
| 748 | ,@(canonicalize-defclass-options options))) |
|---|
| 749 | |
|---|
| 750 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|---|
| 751 | (defstruct method-combination |
|---|
| 752 | name |
|---|
| 753 | operator |
|---|
| 754 | identity-with-one-argument |
|---|
| 755 | documentation) |
|---|
| 756 | |
|---|
| 757 | (defun expand-short-defcombin (whole) |
|---|
| 758 | (let* ((name (cadr whole)) |
|---|
| 759 | (documentation |
|---|
| 760 | (getf (cddr whole) :documentation "")) |
|---|
| 761 | (identity-with-one-arg |
|---|
| 762 | (getf (cddr whole) :identity-with-one-argument nil)) |
|---|
| 763 | (operator |
|---|
| 764 | (getf (cddr whole) :operator name))) |
|---|
| 765 | `(progn |
|---|
| 766 | (setf (get ',name 'method-combination-object) |
|---|
| 767 | (make-method-combination :name ',name |
|---|
| 768 | :operator ',operator |
|---|
| 769 | :identity-with-one-argument ',identity-with-one-arg |
|---|
| 770 | :documentation ',documentation)) |
|---|
| 771 | ',name))) |
|---|
| 772 | |
|---|
| 773 | (defun expand-long-defcombin (whole) |
|---|
| 774 | (declare (ignore whole)) |
|---|
| 775 | (error "The long form of DEFINE-METHOD-COMBINATION is not implemented."))) |
|---|
| 776 | |
|---|
| 777 | (defmacro define-method-combination (&whole form &rest args) |
|---|
| 778 | (declare (ignore args)) |
|---|
| 779 | (if (and (cddr form) |
|---|
| 780 | (listp (caddr form))) |
|---|
| 781 | (expand-long-defcombin form) |
|---|
| 782 | (expand-short-defcombin form))) |
|---|
| 783 | |
|---|
| 784 | (define-method-combination + :identity-with-one-argument t) |
|---|
| 785 | (define-method-combination and :identity-with-one-argument t) |
|---|
| 786 | (define-method-combination append :identity-with-one-argument nil) |
|---|
| 787 | (define-method-combination list :identity-with-one-argument nil) |
|---|
| 788 | (define-method-combination max :identity-with-one-argument t) |
|---|
| 789 | (define-method-combination min :identity-with-one-argument t) |
|---|
| 790 | (define-method-combination nconc :identity-with-one-argument t) |
|---|
| 791 | (define-method-combination or :identity-with-one-argument t) |
|---|
| 792 | (define-method-combination progn :identity-with-one-argument t) |
|---|
| 793 | |
|---|
| 794 | (defstruct eql-specializer |
|---|
| 795 | object) |
|---|
| 796 | |
|---|
| 797 | (defparameter *eql-specializer-table* (make-hash-table :test 'eql)) |
|---|
| 798 | |
|---|
| 799 | (defun intern-eql-specializer (object) |
|---|
| 800 | (or (gethash object *eql-specializer-table*) |
|---|
| 801 | (setf (gethash object *eql-specializer-table*) |
|---|
| 802 | (make-eql-specializer :object object)))) |
|---|
| 803 | |
|---|
| 804 | ;; MOP (p. 216) specifies the following reader generic functions: |
|---|
| 805 | ;; generic-function-argument-precedence-order |
|---|
| 806 | ;; generic-function-declarations |
|---|
| 807 | ;; generic-function-lambda-list |
|---|
| 808 | ;; generic-function-method-class |
|---|
| 809 | ;; generic-function-method-combination |
|---|
| 810 | ;; generic-function-methods |
|---|
| 811 | ;; generic-function-name |
|---|
| 812 | |
|---|
| 813 | (defun generic-function-lambda-list (gf) |
|---|
| 814 | (%generic-function-lambda-list gf)) |
|---|
| 815 | (defsetf generic-function-lambda-list %set-generic-function-lambda-list) |
|---|
| 816 | |
|---|
| 817 | (defun (setf generic-function-documentation) (new-value gf) |
|---|
| 818 | (set-generic-function-documentation gf new-value)) |
|---|
| 819 | |
|---|
| 820 | (defun (setf generic-function-initial-methods) (new-value gf) |
|---|
| 821 | (set-generic-function-initial-methods gf new-value)) |
|---|
| 822 | |
|---|
| 823 | (defun (setf generic-function-methods) (new-value gf) |
|---|
| 824 | (set-generic-function-methods gf new-value)) |
|---|
| 825 | |
|---|
| 826 | (defun (setf generic-function-method-class) (new-value gf) |
|---|
| 827 | (set-generic-function-method-class gf new-value)) |
|---|
| 828 | |
|---|
| 829 | (defun (setf generic-function-method-combination) (new-value gf) |
|---|
| 830 | (set-generic-function-method-combination gf new-value)) |
|---|
| 831 | |
|---|
| 832 | (defun (setf generic-function-argument-precedence-order) (new-value gf) |
|---|
| 833 | (set-generic-function-argument-precedence-order gf new-value)) |
|---|
| 834 | |
|---|
| 835 | (declaim (ftype (function * t) classes-to-emf-table)) |
|---|
| 836 | (defun classes-to-emf-table (gf) |
|---|
| 837 | (generic-function-classes-to-emf-table gf)) |
|---|
| 838 | |
|---|
| 839 | (defun (setf classes-to-emf-table) (new-value gf) |
|---|
| 840 | (set-generic-function-classes-to-emf-table gf new-value)) |
|---|
| 841 | |
|---|
| 842 | (defun (setf method-lambda-list) (new-value method) |
|---|
| 843 | (set-method-lambda-list method new-value)) |
|---|
| 844 | |
|---|
| 845 | (defun (setf method-qualifiers) (new-value method) |
|---|
| 846 | (set-method-qualifiers method new-value)) |
|---|
| 847 | |
|---|
| 848 | (defun (setf method-documentation) (new-value method) |
|---|
| 849 | (set-method-documentation method new-value)) |
|---|
| 850 | |
|---|
| 851 | ;;; defgeneric |
|---|
| 852 | |
|---|
| 853 | (defmacro defgeneric (function-name lambda-list |
|---|
| 854 | &rest options-and-method-descriptions) |
|---|
| 855 | (let ((options ()) |
|---|
| 856 | (methods ()) |
|---|
| 857 | (documentation nil)) |
|---|
| 858 | (dolist (item options-and-method-descriptions) |
|---|
| 859 | (case (car item) |
|---|
| 860 | (declare) ; FIXME |
|---|
| 861 | (:documentation |
|---|
| 862 | (when documentation |
|---|
| 863 | (error 'program-error |
|---|
| 864 | :format-control "Documentation option was specified twice for generic function ~S." |
|---|
| 865 | :format-arguments (list function-name))) |
|---|
| 866 | (setf documentation t) |
|---|
| 867 | (push item options)) |
|---|
| 868 | (:method |
|---|
| 869 | (push |
|---|
| 870 | `(push (defmethod ,function-name ,@(cdr item)) |
|---|
| 871 | (generic-function-initial-methods (fdefinition ',function-name))) |
|---|
| 872 | methods)) |
|---|
| 873 | (t |
|---|
| 874 | (push item options)))) |
|---|
| 875 | (setf options (nreverse options) |
|---|
| 876 | methods (nreverse methods)) |
|---|
| 877 | `(prog1 |
|---|
| 878 | (%defgeneric |
|---|
| 879 | ',function-name |
|---|
| 880 | :lambda-list ',lambda-list |
|---|
| 881 | ,@(canonicalize-defgeneric-options options)) |
|---|
| 882 | ,@methods))) |
|---|
| 883 | |
|---|
| 884 | (defun canonicalize-defgeneric-options (options) |
|---|
| 885 | (mapappend #'canonicalize-defgeneric-option options)) |
|---|
| 886 | |
|---|
| 887 | (defun canonicalize-defgeneric-option (option) |
|---|
| 888 | (case (car option) |
|---|
| 889 | (:generic-function-class |
|---|
| 890 | (list :generic-function-class `(find-class ',(cadr option)))) |
|---|
| 891 | (:method-class |
|---|
| 892 | (list :method-class `(find-class ',(cadr option)))) |
|---|
| 893 | (:method-combination |
|---|
| 894 | (list :method-combination `',(cdr option))) |
|---|
| 895 | (:argument-precedence-order |
|---|
| 896 | (list :argument-precedence-order `',(cdr option))) |
|---|
| 897 | (t |
|---|
| 898 | (list `',(car option) `',(cadr option))))) |
|---|
| 899 | |
|---|
| 900 | ;; From OpenMCL. |
|---|
| 901 | (defun canonicalize-argument-precedence-order (apo req) |
|---|
| 902 | (cond ((equal apo req) nil) |
|---|
| 903 | ((not (eql (length apo) (length req))) |
|---|
| 904 | (error 'program-error |
|---|
| 905 | :format-control "Specified argument precedence order ~S does not match lambda list." |
|---|
| 906 | :format-arguments (list apo))) |
|---|
| 907 | (t (let ((res nil)) |
|---|
| 908 | (dolist (arg apo (nreverse res)) |
|---|
| 909 | (let ((index (position arg req))) |
|---|
| 910 | (if (or (null index) (memq index res)) |
|---|
| 911 | (error 'program-error |
|---|
| 912 | :format-control "Specified argument precedence order ~S does not match lambda list." |
|---|
| 913 | :format-arguments (list apo))) |
|---|
| 914 | (push index res))))))) |
|---|
| 915 | |
|---|
| 916 | (defun find-generic-function (name &optional (errorp t)) |
|---|
| 917 | (let ((function (and (fboundp name) (fdefinition name)))) |
|---|
| 918 | (when function |
|---|
| 919 | (when (typep function 'generic-function) |
|---|
| 920 | (return-from find-generic-function function)) |
|---|
| 921 | (when (and *traced-names* (find name *traced-names* :test #'equal)) |
|---|
| 922 | (setf function (untraced-function name)) |
|---|
| 923 | (when (typep function 'generic-function) |
|---|
| 924 | (return-from find-generic-function function))))) |
|---|
| 925 | (if errorp |
|---|
| 926 | (error "There is no generic function named ~S." name) |
|---|
| 927 | nil)) |
|---|
| 928 | |
|---|
| 929 | (defun lambda-lists-congruent-p (lambda-list1 lambda-list2) |
|---|
| 930 | (let* ((plist1 (analyze-lambda-list lambda-list1)) |
|---|
| 931 | (args1 (getf plist1 :required-args)) |
|---|
| 932 | (plist2 (analyze-lambda-list lambda-list2)) |
|---|
| 933 | (args2 (getf plist2 :required-args))) |
|---|
| 934 | (= (length args1) (length args2)))) |
|---|
| 935 | |
|---|
| 936 | (defun %defgeneric (function-name &rest all-keys) |
|---|
| 937 | (when (fboundp function-name) |
|---|
| 938 | (let ((gf (fdefinition function-name))) |
|---|
| 939 | (when (typep gf 'generic-function) |
|---|
| 940 | ;; Remove methods defined by previous DEFGENERIC forms. |
|---|
| 941 | (dolist (method (generic-function-initial-methods gf)) |
|---|
| 942 | (%remove-method gf method)) |
|---|
| 943 | (setf (generic-function-initial-methods gf) '())))) |
|---|
| 944 | (apply 'ensure-generic-function function-name all-keys)) |
|---|
| 945 | |
|---|
| 946 | (defun ensure-generic-function (function-name |
|---|
| 947 | &rest all-keys |
|---|
| 948 | &key |
|---|
| 949 | lambda-list |
|---|
| 950 | (generic-function-class +the-standard-generic-function-class+) |
|---|
| 951 | (method-class +the-standard-method-class+) |
|---|
| 952 | (method-combination 'standard) |
|---|
| 953 | (argument-precedence-order nil apo-p) |
|---|
| 954 | documentation |
|---|
| 955 | &allow-other-keys) |
|---|
| 956 | (when (autoloadp function-name) |
|---|
| 957 | (resolve function-name)) |
|---|
| 958 | (let ((gf (find-generic-function function-name nil))) |
|---|
| 959 | (if gf |
|---|
| 960 | (progn |
|---|
| 961 | (unless (or (null (generic-function-methods gf)) |
|---|
| 962 | (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf))) |
|---|
| 963 | (error 'simple-error |
|---|
| 964 | :format-control "The lambda list ~S is incompatible with the existing methods of ~S." |
|---|
| 965 | :format-arguments (list lambda-list gf))) |
|---|
| 966 | (setf (generic-function-lambda-list gf) lambda-list) |
|---|
| 967 | (setf (generic-function-documentation gf) documentation) |
|---|
| 968 | (let* ((plist (analyze-lambda-list lambda-list)) |
|---|
| 969 | (required-args (getf plist ':required-args))) |
|---|
| 970 | (%set-gf-required-args gf required-args) |
|---|
| 971 | (when apo-p |
|---|
| 972 | (setf (generic-function-argument-precedence-order gf) |
|---|
| 973 | (if argument-precedence-order |
|---|
| 974 | (canonicalize-argument-precedence-order argument-precedence-order |
|---|
| 975 | required-args) |
|---|
| 976 | nil))) |
|---|
| 977 | (finalize-generic-function gf)) |
|---|
| 978 | gf) |
|---|
| 979 | (progn |
|---|
| 980 | (when (and (null *clos-booting*) |
|---|
| 981 | (fboundp function-name)) |
|---|
| 982 | (error 'program-error |
|---|
| 983 | :format-control "~A already names an ordinary function, macro, or special operator." |
|---|
| 984 | :format-arguments (list function-name))) |
|---|
| 985 | (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+) |
|---|
| 986 | #'make-instance-standard-generic-function |
|---|
| 987 | #'make-instance) |
|---|
| 988 | generic-function-class |
|---|
| 989 | :name function-name |
|---|
| 990 | :method-class method-class |
|---|
| 991 | :method-combination method-combination |
|---|
| 992 | all-keys)) |
|---|
| 993 | gf)))) |
|---|
| 994 | |
|---|
| 995 | (defun initial-discriminating-function (gf args) |
|---|
| 996 | (set-funcallable-instance-function |
|---|
| 997 | gf |
|---|
| 998 | (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) |
|---|
| 999 | #'std-compute-discriminating-function |
|---|
| 1000 | #'compute-discriminating-function) |
|---|
| 1001 | gf)) |
|---|
| 1002 | (apply gf args)) |
|---|
| 1003 | |
|---|
| 1004 | (defun collect-eql-specializer-objects (generic-function) |
|---|
| 1005 | (let ((result nil)) |
|---|
| 1006 | (dolist (method (generic-function-methods generic-function)) |
|---|
| 1007 | (dolist (specializer (%method-specializers method)) |
|---|
| 1008 | (when (typep specializer 'eql-specializer) |
|---|
| 1009 | (pushnew (eql-specializer-object specializer) |
|---|
| 1010 | result |
|---|
| 1011 | :test 'eql)))) |
|---|
| 1012 | result)) |
|---|
| 1013 | |
|---|
| 1014 | (defun finalize-generic-function (gf) |
|---|
| 1015 | (%finalize-generic-function gf) |
|---|
| 1016 | (setf (classes-to-emf-table gf) (make-hash-table :test #'equal)) |
|---|
| 1017 | (%init-eql-specializations gf (collect-eql-specializer-objects gf)) |
|---|
| 1018 | (set-funcallable-instance-function |
|---|
| 1019 | gf #'(lambda (&rest args) |
|---|
| 1020 | (initial-discriminating-function gf args))) |
|---|
| 1021 | ;; FIXME Do we need to warn on redefinition somewhere else? |
|---|
| 1022 | (let ((*warn-on-redefinition* nil)) |
|---|
| 1023 | (setf (fdefinition (%generic-function-name gf)) gf)) |
|---|
| 1024 | (values)) |
|---|
| 1025 | |
|---|
| 1026 | (defun make-instance-standard-generic-function (generic-function-class |
|---|
| 1027 | &key name lambda-list |
|---|
| 1028 | method-class |
|---|
| 1029 | method-combination |
|---|
| 1030 | argument-precedence-order |
|---|
| 1031 | documentation) |
|---|
| 1032 | (declare (ignore generic-function-class)) |
|---|
| 1033 | (let ((gf (std-allocate-instance +the-standard-generic-function-class+))) |
|---|
| 1034 | (%set-generic-function-name gf name) |
|---|
| 1035 | (setf (generic-function-lambda-list gf) lambda-list) |
|---|
| 1036 | (setf (generic-function-initial-methods gf) ()) |
|---|
| 1037 | (setf (generic-function-methods gf) ()) |
|---|
| 1038 | (setf (generic-function-method-class gf) method-class) |
|---|
| 1039 | (setf (generic-function-method-combination gf) method-combination) |
|---|
| 1040 | (setf (generic-function-documentation gf) documentation) |
|---|
| 1041 | (setf (classes-to-emf-table gf) nil) |
|---|
| 1042 | (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) |
|---|
| 1043 | (required-args (getf plist ':required-args))) |
|---|
| 1044 | (%set-gf-required-args gf required-args) |
|---|
| 1045 | (setf (generic-function-argument-precedence-order gf) |
|---|
| 1046 | (if argument-precedence-order |
|---|
| 1047 | (canonicalize-argument-precedence-order argument-precedence-order |
|---|
| 1048 | required-args) |
|---|
| 1049 | nil))) |
|---|
| 1050 | (finalize-generic-function gf) |
|---|
| 1051 | gf)) |
|---|
| 1052 | |
|---|
| 1053 | (defun canonicalize-specializers (specializers) |
|---|
| 1054 | (mapcar #'canonicalize-specializer specializers)) |
|---|
| 1055 | |
|---|
| 1056 | (defun canonicalize-specializer (specializer) |
|---|
| 1057 | (cond ((classp specializer) |
|---|
| 1058 | specializer) |
|---|
| 1059 | ((eql-specializer-p specializer) |
|---|
| 1060 | specializer) |
|---|
| 1061 | ((symbolp specializer) |
|---|
| 1062 | (find-class specializer)) |
|---|
| 1063 | ((and (consp specializer) |
|---|
| 1064 | (eq (car specializer) 'eql)) |
|---|
| 1065 | (let ((object (cadr specializer))) |
|---|
| 1066 | (when (and (consp object) |
|---|
| 1067 | (eq (car object) 'quote)) |
|---|
| 1068 | (setf object (cadr object))) |
|---|
| 1069 | (intern-eql-specializer object))) |
|---|
| 1070 | ((and (consp specializer) |
|---|
| 1071 | (eq (car specializer) 'java:jclass)) |
|---|
| 1072 | (let ((jclass (eval specializer))) |
|---|
| 1073 | (java::ensure-java-class jclass))) |
|---|
| 1074 | (t |
|---|
| 1075 | (error "Unknown specializer: ~S" specializer)))) |
|---|
| 1076 | |
|---|
| 1077 | (defun parse-defmethod (args) |
|---|
| 1078 | (let ((function-name (car args)) |
|---|
| 1079 | (qualifiers ()) |
|---|
| 1080 | (specialized-lambda-list ()) |
|---|
| 1081 | (body ()) |
|---|
| 1082 | (parse-state :qualifiers)) |
|---|
| 1083 | (dolist (arg (cdr args)) |
|---|
| 1084 | (ecase parse-state |
|---|
| 1085 | (:qualifiers |
|---|
| 1086 | (if (and (atom arg) (not (null arg))) |
|---|
| 1087 | (push arg qualifiers) |
|---|
| 1088 | (progn |
|---|
| 1089 | (setf specialized-lambda-list arg) |
|---|
| 1090 | (setf parse-state :body)))) |
|---|
| 1091 | (:body (push arg body)))) |
|---|
| 1092 | (setf qualifiers (nreverse qualifiers) |
|---|
| 1093 | body (nreverse body)) |
|---|
| 1094 | (multiple-value-bind (real-body declarations documentation) |
|---|
| 1095 | (parse-body body) |
|---|
| 1096 | (values function-name |
|---|
| 1097 | qualifiers |
|---|
| 1098 | (extract-lambda-list specialized-lambda-list) |
|---|
| 1099 | (extract-specializers specialized-lambda-list) |
|---|
| 1100 | documentation |
|---|
| 1101 | declarations |
|---|
| 1102 | (list* 'block |
|---|
| 1103 | (fdefinition-block-name function-name) |
|---|
| 1104 | real-body))))) |
|---|
| 1105 | |
|---|
| 1106 | (defun required-portion (gf args) |
|---|
| 1107 | (let ((number-required (length (gf-required-args gf)))) |
|---|
| 1108 | (when (< (length args) number-required) |
|---|
| 1109 | (error 'program-error |
|---|
| 1110 | :format-control "Not enough arguments for generic function ~S." |
|---|
| 1111 | :format-arguments (list (%generic-function-name gf)))) |
|---|
| 1112 | (subseq args 0 number-required))) |
|---|
| 1113 | |
|---|
| 1114 | (defun extract-lambda-list (specialized-lambda-list) |
|---|
| 1115 | (let* ((plist (analyze-lambda-list specialized-lambda-list)) |
|---|
| 1116 | (requireds (getf plist :required-names)) |
|---|
| 1117 | (rv (getf plist :rest-var)) |
|---|
| 1118 | (ks (getf plist :key-args)) |
|---|
| 1119 | (keysp (getf plist :keysp)) |
|---|
| 1120 | (aok (getf plist :allow-other-keys)) |
|---|
| 1121 | (opts (getf plist :optional-args)) |
|---|
| 1122 | (auxs (getf plist :auxiliary-args))) |
|---|
| 1123 | `(,@requireds |
|---|
| 1124 | ,@(if rv `(&rest ,rv) ()) |
|---|
| 1125 | ,@(if (or ks keysp aok) `(&key ,@ks) ()) |
|---|
| 1126 | ,@(if aok '(&allow-other-keys) ()) |
|---|
| 1127 | ,@(if opts `(&optional ,@opts) ()) |
|---|
| 1128 | ,@(if auxs `(&aux ,@auxs) ())))) |
|---|
| 1129 | |
|---|
| 1130 | (defun extract-specializers (specialized-lambda-list) |
|---|
| 1131 | (let ((plist (analyze-lambda-list specialized-lambda-list))) |
|---|
| 1132 | (getf plist ':specializers))) |
|---|
| 1133 | |
|---|
| 1134 | (defun get-keyword-from-arg (arg) |
|---|
| 1135 | (if (listp arg) |
|---|
| 1136 | (if (listp (car arg)) |
|---|
| 1137 | (caar arg) |
|---|
| 1138 | (make-keyword (car arg))) |
|---|
| 1139 | (make-keyword arg))) |
|---|
| 1140 | |
|---|
| 1141 | (defun analyze-lambda-list (lambda-list) |
|---|
| 1142 | (let ((keys ()) ; Just the keywords |
|---|
| 1143 | (key-args ()) ; Keywords argument specs |
|---|
| 1144 | (keysp nil) ; |
|---|
| 1145 | (required-names ()) ; Just the variable names |
|---|
| 1146 | (required-args ()) ; Variable names & specializers |
|---|
| 1147 | (specializers ()) ; Just the specializers |
|---|
| 1148 | (rest-var nil) |
|---|
| 1149 | (optionals ()) |
|---|
| 1150 | (auxs ()) |
|---|
| 1151 | (allow-other-keys nil) |
|---|
| 1152 | (state :parsing-required)) |
|---|
| 1153 | (dolist (arg lambda-list) |
|---|
| 1154 | (if (member arg lambda-list-keywords) |
|---|
| 1155 | (ecase arg |
|---|
| 1156 | (&optional |
|---|
| 1157 | (setq state :parsing-optional)) |
|---|
| 1158 | (&rest |
|---|
| 1159 | (setq state :parsing-rest)) |
|---|
| 1160 | (&key |
|---|
| 1161 | (setq keysp t) |
|---|
| 1162 | (setq state :parsing-key)) |
|---|
| 1163 | (&allow-other-keys |
|---|
| 1164 | (setq allow-other-keys 't)) |
|---|
| 1165 | (&aux |
|---|
| 1166 | (setq state :parsing-aux))) |
|---|
| 1167 | (case state |
|---|
| 1168 | (:parsing-required |
|---|
| 1169 | (push-on-end arg required-args) |
|---|
| 1170 | (if (listp arg) |
|---|
| 1171 | (progn (push-on-end (car arg) required-names) |
|---|
| 1172 | (push-on-end (cadr arg) specializers)) |
|---|
| 1173 | (progn (push-on-end arg required-names) |
|---|
| 1174 | (push-on-end 't specializers)))) |
|---|
| 1175 | (:parsing-optional (push-on-end arg optionals)) |
|---|
| 1176 | (:parsing-rest (setq rest-var arg)) |
|---|
| 1177 | (:parsing-key |
|---|
| 1178 | (push-on-end (get-keyword-from-arg arg) keys) |
|---|
| 1179 | (push-on-end arg key-args)) |
|---|
| 1180 | (:parsing-aux (push-on-end arg auxs))))) |
|---|
| 1181 | (list :required-names required-names |
|---|
| 1182 | :required-args required-args |
|---|
| 1183 | :specializers specializers |
|---|
| 1184 | :rest-var rest-var |
|---|
| 1185 | :keywords keys |
|---|
| 1186 | :key-args key-args |
|---|
| 1187 | :keysp keysp |
|---|
| 1188 | :auxiliary-args auxs |
|---|
| 1189 | :optional-args optionals |
|---|
| 1190 | :allow-other-keys allow-other-keys))) |
|---|
| 1191 | |
|---|
| 1192 | #+nil |
|---|
| 1193 | (defun check-method-arg-info (gf arg-info method) |
|---|
| 1194 | (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) |
|---|
| 1195 | (analyze-lambda-list (if (consp method) |
|---|
| 1196 | (early-method-lambda-list method) |
|---|
| 1197 | (method-lambda-list method))) |
|---|
| 1198 | (flet ((lose (string &rest args) |
|---|
| 1199 | (error 'simple-program-error |
|---|
| 1200 | :format-control "~@<attempt to add the method~2I~_~S~I~_~ |
|---|
| 1201 | to the generic function~2I~_~S;~I~_~ |
|---|
| 1202 | but ~?~:>" |
|---|
| 1203 | :format-arguments (list method gf string args))) |
|---|
| 1204 | (comparison-description (x y) |
|---|
| 1205 | (if (> x y) "more" "fewer"))) |
|---|
| 1206 | (let ((gf-nreq (arg-info-number-required arg-info)) |
|---|
| 1207 | (gf-nopt (arg-info-number-optional arg-info)) |
|---|
| 1208 | (gf-key/rest-p (arg-info-key/rest-p arg-info)) |
|---|
| 1209 | (gf-keywords (arg-info-keys arg-info))) |
|---|
| 1210 | (unless (= nreq gf-nreq) |
|---|
| 1211 | (lose |
|---|
| 1212 | "the method has ~A required arguments than the generic function." |
|---|
| 1213 | (comparison-description nreq gf-nreq))) |
|---|
| 1214 | (unless (= nopt gf-nopt) |
|---|
| 1215 | (lose |
|---|
| 1216 | "the method has ~A optional arguments than the generic function." |
|---|
| 1217 | (comparison-description nopt gf-nopt))) |
|---|
| 1218 | (unless (eq (or keysp restp) gf-key/rest-p) |
|---|
| 1219 | (lose |
|---|
| 1220 | "the method and generic function differ in whether they accept~_~ |
|---|
| 1221 | &REST or &KEY arguments.")) |
|---|
| 1222 | (when (consp gf-keywords) |
|---|
| 1223 | (unless (or (and restp (not keysp)) |
|---|
| 1224 | allow-other-keys-p |
|---|
| 1225 | (every (lambda (k) (memq k keywords)) gf-keywords)) |
|---|
| 1226 | (lose "the method does not accept each of the &KEY arguments~2I~_~ |
|---|
| 1227 | ~S." |
|---|
| 1228 | gf-keywords))))))) |
|---|
| 1229 | |
|---|
| 1230 | (defun check-method-lambda-list (method-lambda-list gf-lambda-list) |
|---|
| 1231 | (let* ((gf-restp (not (null (memq '&rest gf-lambda-list)))) |
|---|
| 1232 | (gf-plist (analyze-lambda-list gf-lambda-list)) |
|---|
| 1233 | (gf-keysp (getf gf-plist :keysp)) |
|---|
| 1234 | (gf-keywords (getf gf-plist :keywords)) |
|---|
| 1235 | (method-plist (analyze-lambda-list method-lambda-list)) |
|---|
| 1236 | (method-restp (not (null (memq '&rest method-lambda-list)))) |
|---|
| 1237 | (method-keysp (getf method-plist :keysp)) |
|---|
| 1238 | (method-keywords (getf method-plist :keywords)) |
|---|
| 1239 | (method-allow-other-keys-p (getf method-plist :allow-other-keys))) |
|---|
| 1240 | (unless (= (length (getf gf-plist :required-args)) |
|---|
| 1241 | (length (getf method-plist :required-args))) |
|---|
| 1242 | (error "The method has the wrong number of required arguments for the generic function.")) |
|---|
| 1243 | (unless (= (length (getf gf-plist :optional-args)) |
|---|
| 1244 | (length (getf method-plist :optional-args))) |
|---|
| 1245 | (error "The method has the wrong number of optional arguments for the generic function.")) |
|---|
| 1246 | (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp)) |
|---|
| 1247 | (error "The method and the generic function differ in whether they accept &REST or &KEY arguments.")) |
|---|
| 1248 | (when (consp gf-keywords) |
|---|
| 1249 | (unless (or (and method-restp (not method-keysp)) |
|---|
| 1250 | method-allow-other-keys-p |
|---|
| 1251 | (every (lambda (k) (memq k method-keywords)) gf-keywords)) |
|---|
| 1252 | (error "The method does not accept all of the keyword arguments defined for the generic function."))))) |
|---|
| 1253 | |
|---|
| 1254 | (declaim (ftype (function * method) ensure-method)) |
|---|
| 1255 | (defun ensure-method (name &rest all-keys) |
|---|
| 1256 | (let ((method-lambda-list (getf all-keys :lambda-list)) |
|---|
| 1257 | (gf (find-generic-function name nil))) |
|---|
| 1258 | (if gf |
|---|
| 1259 | (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) |
|---|
| 1260 | (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) |
|---|
| 1261 | (let ((method |
|---|
| 1262 | (if (eq (generic-function-method-class gf) +the-standard-method-class+) |
|---|
| 1263 | (apply #'make-instance-standard-method gf all-keys) |
|---|
| 1264 | (apply #'make-instance (generic-function-method-class gf) all-keys)))) |
|---|
| 1265 | (%add-method gf method) |
|---|
| 1266 | method))) |
|---|
| 1267 | |
|---|
| 1268 | (defun make-instance-standard-method (gf |
|---|
| 1269 | &key |
|---|
| 1270 | lambda-list |
|---|
| 1271 | qualifiers |
|---|
| 1272 | specializers |
|---|
| 1273 | documentation |
|---|
| 1274 | function |
|---|
| 1275 | fast-function) |
|---|
| 1276 | (declare (ignore gf)) |
|---|
| 1277 | (let ((method (std-allocate-instance +the-standard-method-class+))) |
|---|
| 1278 | (setf (method-lambda-list method) lambda-list) |
|---|
| 1279 | (setf (method-qualifiers method) qualifiers) |
|---|
| 1280 | (%set-method-specializers method (canonicalize-specializers specializers)) |
|---|
| 1281 | (setf (method-documentation method) documentation) |
|---|
| 1282 | (%set-method-generic-function method nil) |
|---|
| 1283 | (%set-method-function method function) |
|---|
| 1284 | (%set-method-fast-function method fast-function) |
|---|
| 1285 | method)) |
|---|
| 1286 | |
|---|
| 1287 | (defun %add-method (gf method) |
|---|
| 1288 | (when (%method-generic-function method) |
|---|
| 1289 | (error 'simple-error |
|---|
| 1290 | :format-control "ADD-METHOD: ~S is a method of ~S." |
|---|
| 1291 | :format-arguments (list method (%method-generic-function method)))) |
|---|
| 1292 | ;; Remove existing method with same qualifiers and specializers (if any). |
|---|
| 1293 | (let ((old-method (%find-method gf (method-qualifiers method) |
|---|
| 1294 | (%method-specializers method) nil))) |
|---|
| 1295 | (when old-method |
|---|
| 1296 | (%remove-method gf old-method))) |
|---|
| 1297 | (%set-method-generic-function method gf) |
|---|
| 1298 | (push method (generic-function-methods gf)) |
|---|
| 1299 | (dolist (specializer (%method-specializers method)) |
|---|
| 1300 | (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? |
|---|
| 1301 | (pushnew method (class-direct-methods specializer)))) |
|---|
| 1302 | (finalize-generic-function gf) |
|---|
| 1303 | gf) |
|---|
| 1304 | |
|---|
| 1305 | (defun %remove-method (gf method) |
|---|
| 1306 | (setf (generic-function-methods gf) |
|---|
| 1307 | (remove method (generic-function-methods gf))) |
|---|
| 1308 | (%set-method-generic-function method nil) |
|---|
| 1309 | (dolist (specializer (%method-specializers method)) |
|---|
| 1310 | (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? |
|---|
| 1311 | (setf (class-direct-methods specializer) |
|---|
| 1312 | (remove method (class-direct-methods specializer))))) |
|---|
| 1313 | (finalize-generic-function gf) |
|---|
| 1314 | gf) |
|---|
| 1315 | |
|---|
| 1316 | (defun %find-method (gf qualifiers specializers &optional (errorp t)) |
|---|
| 1317 | ;; "If the specializers argument does not correspond in length to the number |
|---|
| 1318 | ;; of required arguments of the generic-function, an an error of type ERROR |
|---|
| 1319 | ;; is signaled." |
|---|
| 1320 | (unless (= (length specializers) (length (gf-required-args gf))) |
|---|
| 1321 | (error "The specializers argument has length ~S, but ~S has ~S required parameters." |
|---|
| 1322 | (length specializers) |
|---|
| 1323 | gf |
|---|
| 1324 | (length (gf-required-args gf)))) |
|---|
| 1325 | (let* ((canonical-specializers (canonicalize-specializers specializers)) |
|---|
| 1326 | (method |
|---|
| 1327 | (find-if #'(lambda (method) |
|---|
| 1328 | (and (equal qualifiers |
|---|
| 1329 | (method-qualifiers method)) |
|---|
| 1330 | (equal canonical-specializers |
|---|
| 1331 | (%method-specializers method)))) |
|---|
| 1332 | (generic-function-methods gf)))) |
|---|
| 1333 | (if (and (null method) errorp) |
|---|
| 1334 | (error "No such method for ~S." (%generic-function-name gf)) |
|---|
| 1335 | method))) |
|---|
| 1336 | |
|---|
| 1337 | (defun fast-callable-p (gf) |
|---|
| 1338 | (and (eq (generic-function-method-combination gf) 'standard) |
|---|
| 1339 | (null (intersection (%generic-function-lambda-list gf) |
|---|
| 1340 | '(&rest &optional &key &allow-other-keys &aux))))) |
|---|
| 1341 | |
|---|
| 1342 | (declaim (ftype (function * t) slow-method-lookup-1)) |
|---|
| 1343 | |
|---|
| 1344 | (declaim (ftype (function (t t t) t) slow-reader-lookup)) |
|---|
| 1345 | (defun slow-reader-lookup (gf layout slot-name) |
|---|
| 1346 | (let ((location (layout-slot-location layout slot-name))) |
|---|
| 1347 | (cache-slot-location gf layout location) |
|---|
| 1348 | location)) |
|---|
| 1349 | |
|---|
| 1350 | (defun std-compute-discriminating-function (gf) |
|---|
| 1351 | (let ((code |
|---|
| 1352 | (cond |
|---|
| 1353 | ((and (= (length (generic-function-methods gf)) 1) |
|---|
| 1354 | (typep (car (generic-function-methods gf)) 'standard-reader-method)) |
|---|
| 1355 | ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) |
|---|
| 1356 | |
|---|
| 1357 | (let* ((method (%car (generic-function-methods gf))) |
|---|
| 1358 | (class (car (%method-specializers method))) |
|---|
| 1359 | (slot-name (reader-method-slot-name method))) |
|---|
| 1360 | #'(lambda (arg) |
|---|
| 1361 | (declare (optimize speed)) |
|---|
| 1362 | (let* ((layout (std-instance-layout arg)) |
|---|
| 1363 | (location (get-cached-slot-location gf layout))) |
|---|
| 1364 | (unless location |
|---|
| 1365 | (unless (simple-typep arg class) |
|---|
| 1366 | ;; FIXME no applicable method |
|---|
| 1367 | (error 'simple-type-error |
|---|
| 1368 | :datum arg |
|---|
| 1369 | :expected-type class)) |
|---|
| 1370 | (setf location (slow-reader-lookup gf layout slot-name))) |
|---|
| 1371 | (if (consp location) |
|---|
| 1372 | ;; Shared slot. |
|---|
| 1373 | (cdr location) |
|---|
| 1374 | (standard-instance-access arg location)))))) |
|---|
| 1375 | |
|---|
| 1376 | (t |
|---|
| 1377 | (let* ((emf-table (classes-to-emf-table gf)) |
|---|
| 1378 | (number-required (length (gf-required-args gf))) |
|---|
| 1379 | (lambda-list (%generic-function-lambda-list gf)) |
|---|
| 1380 | (exact (null (intersection lambda-list |
|---|
| 1381 | '(&rest &optional &key |
|---|
| 1382 | &allow-other-keys &aux))))) |
|---|
| 1383 | (if exact |
|---|
| 1384 | (cond |
|---|
| 1385 | ((= number-required 1) |
|---|
| 1386 | (cond |
|---|
| 1387 | ((and (eq (generic-function-method-combination gf) 'standard) |
|---|
| 1388 | (= (length (generic-function-methods gf)) 1)) |
|---|
| 1389 | (let* ((method (%car (generic-function-methods gf))) |
|---|
| 1390 | (specializer (car (%method-specializers method))) |
|---|
| 1391 | (function (or (%method-fast-function method) |
|---|
| 1392 | (%method-function method)))) |
|---|
| 1393 | (if (eql-specializer-p specializer) |
|---|
| 1394 | (let ((specializer-object (eql-specializer-object specializer))) |
|---|
| 1395 | #'(lambda (arg) |
|---|
| 1396 | (declare (optimize speed)) |
|---|
| 1397 | (if (eql arg specializer-object) |
|---|
| 1398 | (funcall function arg) |
|---|
| 1399 | (no-applicable-method gf (list arg))))) |
|---|
| 1400 | #'(lambda (arg) |
|---|
| 1401 | (declare (optimize speed)) |
|---|
| 1402 | (unless (simple-typep arg specializer) |
|---|
| 1403 | ;; FIXME no applicable method |
|---|
| 1404 | (error 'simple-type-error |
|---|
| 1405 | :datum arg |
|---|
| 1406 | :expected-type specializer)) |
|---|
| 1407 | (funcall function arg))))) |
|---|
| 1408 | (t |
|---|
| 1409 | #'(lambda (arg) |
|---|
| 1410 | (declare (optimize speed)) |
|---|
| 1411 | (let* ((specialization |
|---|
| 1412 | (%get-arg-specialization gf arg)) |
|---|
| 1413 | (emfun (or (gethash1 specialization |
|---|
| 1414 | emf-table) |
|---|
| 1415 | (slow-method-lookup-1 |
|---|
| 1416 | gf arg specialization)))) |
|---|
| 1417 | (if emfun |
|---|
| 1418 | (funcall emfun (list arg)) |
|---|
| 1419 | (apply #'no-applicable-method gf (list arg)))))))) |
|---|
| 1420 | ((= number-required 2) |
|---|
| 1421 | #'(lambda (arg1 arg2) |
|---|
| 1422 | (declare (optimize speed)) |
|---|
| 1423 | (let* ((args (list arg1 arg2)) |
|---|
| 1424 | (emfun (get-cached-emf gf args))) |
|---|
| 1425 | (if emfun |
|---|
| 1426 | (funcall emfun args) |
|---|
| 1427 | (slow-method-lookup gf args))))) |
|---|
| 1428 | ((= number-required 3) |
|---|
| 1429 | #'(lambda (arg1 arg2 arg3) |
|---|
| 1430 | (declare (optimize speed)) |
|---|
| 1431 | (let* ((args (list arg1 arg2 arg3)) |
|---|
| 1432 | (emfun (get-cached-emf gf args))) |
|---|
| 1433 | (if emfun |
|---|
| 1434 | (funcall emfun args) |
|---|
| 1435 | (slow-method-lookup gf args))))) |
|---|
| 1436 | (t |
|---|
| 1437 | #'(lambda (&rest args) |
|---|
| 1438 | (declare (optimize speed)) |
|---|
| 1439 | (let ((len (length args))) |
|---|
| 1440 | (unless (= len number-required) |
|---|
| 1441 | (error 'program-error |
|---|
| 1442 | :format-control "Not enough arguments for generic function ~S." |
|---|
| 1443 | :format-arguments (list (%generic-function-name gf))))) |
|---|
| 1444 | (let ((emfun (get-cached-emf gf args))) |
|---|
| 1445 | (if emfun |
|---|
| 1446 | (funcall emfun args) |
|---|
| 1447 | (slow-method-lookup gf args)))))) |
|---|
| 1448 | #'(lambda (&rest args) |
|---|
| 1449 | (declare (optimize speed)) |
|---|
| 1450 | (let ((len (length args))) |
|---|
| 1451 | (unless (>= len number-required) |
|---|
| 1452 | (error 'program-error |
|---|
| 1453 | :format-control "Not enough arguments for generic function ~S." |
|---|
| 1454 | :format-arguments (list (%generic-function-name gf))))) |
|---|
| 1455 | (let ((emfun (get-cached-emf gf args))) |
|---|
| 1456 | (if emfun |
|---|
| 1457 | (funcall emfun args) |
|---|
| 1458 | (slow-method-lookup gf args)))))))))) |
|---|
| 1459 | |
|---|
| 1460 | code)) |
|---|
| 1461 | |
|---|
| 1462 | (defun sort-methods (methods gf required-classes) |
|---|
| 1463 | (if (or (null methods) (null (%cdr methods))) |
|---|
| 1464 | methods |
|---|
| 1465 | (sort methods |
|---|
| 1466 | (if (eq (class-of gf) +the-standard-generic-function-class+) |
|---|
| 1467 | #'(lambda (m1 m2) |
|---|
| 1468 | (std-method-more-specific-p m1 m2 required-classes |
|---|
| 1469 | (generic-function-argument-precedence-order gf))) |
|---|
| 1470 | #'(lambda (m1 m2) |
|---|
| 1471 | (method-more-specific-p gf m1 m2 required-classes)))))) |
|---|
| 1472 | |
|---|
| 1473 | (defun method-applicable-p (method args) |
|---|
| 1474 | (do* ((specializers (%method-specializers method) (cdr specializers)) |
|---|
| 1475 | (args args (cdr args))) |
|---|
| 1476 | ((null specializers) t) |
|---|
| 1477 | (let ((specializer (car specializers))) |
|---|
| 1478 | (if (typep specializer 'eql-specializer) |
|---|
| 1479 | (unless (eql (car args) (eql-specializer-object specializer)) |
|---|
| 1480 | (return nil)) |
|---|
| 1481 | (unless (subclassp (class-of (car args)) specializer) |
|---|
| 1482 | (return nil)))))) |
|---|
| 1483 | |
|---|
| 1484 | (defun %compute-applicable-methods (gf args) |
|---|
| 1485 | (let ((required-classes (mapcar #'class-of (required-portion gf args))) |
|---|
| 1486 | (methods '())) |
|---|
| 1487 | (dolist (method (generic-function-methods gf)) |
|---|
| 1488 | (when (method-applicable-p method args) |
|---|
| 1489 | (push method methods))) |
|---|
| 1490 | (sort-methods methods gf required-classes))) |
|---|
| 1491 | |
|---|
| 1492 | ;;; METHOD-APPLICABLE-USING-CLASSES-P |
|---|
| 1493 | ;;; |
|---|
| 1494 | ;;; If the first return value is T, METHOD is definitely applicable to |
|---|
| 1495 | ;;; arguments that are instances of CLASSES. If the first value is |
|---|
| 1496 | ;;; NIL and the second value is T, METHOD is definitely not applicable |
|---|
| 1497 | ;;; to arguments that are instances of CLASSES; if the second value is |
|---|
| 1498 | ;;; NIL the applicability of METHOD cannot be determined by inspecting |
|---|
| 1499 | ;;; the classes of its arguments only. |
|---|
| 1500 | ;;; |
|---|
| 1501 | (defun method-applicable-using-classes-p (method classes) |
|---|
| 1502 | (do* ((specializers (%method-specializers method) (cdr specializers)) |
|---|
| 1503 | (classes classes (cdr classes)) |
|---|
| 1504 | (knownp t)) |
|---|
| 1505 | ((null specializers) |
|---|
| 1506 | (if knownp (values t t) (values nil nil))) |
|---|
| 1507 | (let ((specializer (car specializers))) |
|---|
| 1508 | (if (typep specializer 'eql-specializer) |
|---|
| 1509 | (if (eql (class-of (eql-specializer-object specializer)) |
|---|
| 1510 | (car classes)) |
|---|
| 1511 | (setf knownp nil) |
|---|
| 1512 | (return (values nil t))) |
|---|
| 1513 | (unless (subclassp (car classes) specializer) |
|---|
| 1514 | (return (values nil t))))))) |
|---|
| 1515 | |
|---|
| 1516 | (defun slow-method-lookup (gf args) |
|---|
| 1517 | (let ((applicable-methods (%compute-applicable-methods gf args))) |
|---|
| 1518 | (if applicable-methods |
|---|
| 1519 | (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) |
|---|
| 1520 | #'std-compute-effective-method-function |
|---|
| 1521 | #'compute-effective-method-function) |
|---|
| 1522 | gf applicable-methods))) |
|---|
| 1523 | (cache-emf gf args emfun) |
|---|
| 1524 | (funcall emfun args)) |
|---|
| 1525 | (apply #'no-applicable-method gf args)))) |
|---|
| 1526 | |
|---|
| 1527 | (defun slow-method-lookup-1 (gf arg arg-specialization) |
|---|
| 1528 | (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) |
|---|
| 1529 | (if applicable-methods |
|---|
| 1530 | (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) |
|---|
| 1531 | #'std-compute-effective-method-function |
|---|
| 1532 | #'compute-effective-method-function) |
|---|
| 1533 | gf applicable-methods))) |
|---|
| 1534 | (when emfun |
|---|
| 1535 | (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun)) |
|---|
| 1536 | emfun)))) |
|---|
| 1537 | |
|---|
| 1538 | (defun sub-specializer-p (c1 c2 c-arg) |
|---|
| 1539 | (find c2 (cdr (memq c1 (%class-precedence-list c-arg))))) |
|---|
| 1540 | |
|---|
| 1541 | (defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order) |
|---|
| 1542 | (if argument-precedence-order |
|---|
| 1543 | (let ((specializers-1 (%method-specializers method1)) |
|---|
| 1544 | (specializers-2 (%method-specializers method2))) |
|---|
| 1545 | (dolist (index argument-precedence-order) |
|---|
| 1546 | (let ((spec1 (nth index specializers-1)) |
|---|
| 1547 | (spec2 (nth index specializers-2))) |
|---|
| 1548 | (unless (eq spec1 spec2) |
|---|
| 1549 | (cond ((eql-specializer-p spec1) |
|---|
| 1550 | (return t)) |
|---|
| 1551 | ((eql-specializer-p spec2) |
|---|
| 1552 | (return nil)) |
|---|
| 1553 | (t |
|---|
| 1554 | (return (sub-specializer-p spec1 spec2 |
|---|
| 1555 | (nth index required-classes))))))))) |
|---|
| 1556 | (do ((specializers-1 (%method-specializers method1) (cdr specializers-1)) |
|---|
| 1557 | (specializers-2 (%method-specializers method2) (cdr specializers-2)) |
|---|
| 1558 | (classes required-classes (cdr classes))) |
|---|
| 1559 | ((null specializers-1) nil) |
|---|
| 1560 | (let ((spec1 (car specializers-1)) |
|---|
| 1561 | (spec2 (car specializers-2))) |
|---|
| 1562 | (unless (eq spec1 spec2) |
|---|
| 1563 | (cond ((eql-specializer-p spec1) |
|---|
| 1564 | (return t)) |
|---|
| 1565 | ((eql-specializer-p spec2) |
|---|
| 1566 | (return nil)) |
|---|
| 1567 | (t |
|---|
| 1568 | (return (sub-specializer-p spec1 spec2 (car classes)))))))))) |
|---|
| 1569 | |
|---|
| 1570 | (defun primary-method-p (method) |
|---|
| 1571 | (null (intersection '(:before :after :around) (method-qualifiers method)))) |
|---|
| 1572 | |
|---|
| 1573 | (defun before-method-p (method) |
|---|
| 1574 | (equal '(:before) (method-qualifiers method))) |
|---|
| 1575 | |
|---|
| 1576 | (defun after-method-p (method) |
|---|
| 1577 | (equal '(:after) (method-qualifiers method))) |
|---|
| 1578 | |
|---|
| 1579 | (defun around-method-p (method) |
|---|
| 1580 | (equal '(:around) (method-qualifiers method))) |
|---|
| 1581 | |
|---|
| 1582 | (defun std-compute-effective-method-function (gf methods) |
|---|
| 1583 | (let* ((mc (generic-function-method-combination gf)) |
|---|
| 1584 | (mc-name (if (atom mc) mc (%car mc))) |
|---|
| 1585 | (options (if (atom mc) '() (%cdr mc))) |
|---|
| 1586 | (order (car options)) |
|---|
| 1587 | (primaries '()) |
|---|
| 1588 | (arounds '()) |
|---|
| 1589 | around |
|---|
| 1590 | emf-form) |
|---|
| 1591 | (dolist (m methods) |
|---|
| 1592 | (let ((qualifiers (method-qualifiers m))) |
|---|
| 1593 | (cond ((null qualifiers) |
|---|
| 1594 | (if (eq mc-name 'standard) |
|---|
| 1595 | (push m primaries) |
|---|
| 1596 | (error "Method combination type mismatch."))) |
|---|
| 1597 | ((cdr qualifiers) |
|---|
| 1598 | (error "Invalid method qualifiers.")) |
|---|
| 1599 | ((eq (car qualifiers) :around) |
|---|
| 1600 | (push m arounds)) |
|---|
| 1601 | ((eq (car qualifiers) mc-name) |
|---|
| 1602 | (push m primaries)) |
|---|
| 1603 | ((memq (car qualifiers) '(:before :after))) |
|---|
| 1604 | (t |
|---|
| 1605 | (error "Invalid method qualifiers."))))) |
|---|
| 1606 | (unless (eq order :most-specific-last) |
|---|
| 1607 | (setf primaries (nreverse primaries))) |
|---|
| 1608 | (setf arounds (nreverse arounds)) |
|---|
| 1609 | (setf around (car arounds)) |
|---|
| 1610 | (when (null primaries) |
|---|
| 1611 | (error "No primary methods for the generic function ~S." gf)) |
|---|
| 1612 | (cond |
|---|
| 1613 | (around |
|---|
| 1614 | (let ((next-emfun |
|---|
| 1615 | (funcall |
|---|
| 1616 | (if (eq (class-of gf) +the-standard-generic-function-class+) |
|---|
| 1617 | #'std-compute-effective-method-function |
|---|
| 1618 | #'compute-effective-method-function) |
|---|
| 1619 | gf (remove around methods)))) |
|---|
| 1620 | (setf emf-form |
|---|
| 1621 | ;;; `(lambda (args) |
|---|
| 1622 | ;;; (funcall ,(%method-function around) args ,next-emfun)) |
|---|
| 1623 | (generate-emf-lambda (%method-function around) next-emfun) |
|---|
| 1624 | ))) |
|---|
| 1625 | ((eq mc-name 'standard) |
|---|
| 1626 | (let* ((next-emfun (compute-primary-emfun (cdr primaries))) |
|---|
| 1627 | (befores (remove-if-not #'before-method-p methods)) |
|---|
| 1628 | (reverse-afters |
|---|
| 1629 | (reverse (remove-if-not #'after-method-p methods)))) |
|---|
| 1630 | (setf emf-form |
|---|
| 1631 | (cond |
|---|
| 1632 | ((and (null befores) (null reverse-afters)) |
|---|
| 1633 | (let ((fast-function (%method-fast-function (car primaries)))) |
|---|
| 1634 | |
|---|
| 1635 | (if fast-function |
|---|
| 1636 | (ecase (length (gf-required-args gf)) |
|---|
| 1637 | (1 |
|---|
| 1638 | #'(lambda (args) |
|---|
| 1639 | (declare (optimize speed)) |
|---|
| 1640 | (funcall fast-function (car args)))) |
|---|
| 1641 | (2 |
|---|
| 1642 | #'(lambda (args) |
|---|
| 1643 | (declare (optimize speed)) |
|---|
| 1644 | (funcall fast-function (car args) (cadr args))))) |
|---|
| 1645 | ;; `(lambda (args) |
|---|
| 1646 | ;; (declare (optimize speed)) |
|---|
| 1647 | ;; (funcall ,(%method-function (car primaries)) args ,next-emfun)) |
|---|
| 1648 | (generate-emf-lambda (%method-function (car primaries)) |
|---|
| 1649 | next-emfun)))) |
|---|
| 1650 | (t |
|---|
| 1651 | (let ((method-function (%method-function (car primaries)))) |
|---|
| 1652 | |
|---|
| 1653 | #'(lambda (args) |
|---|
| 1654 | (declare (optimize speed)) |
|---|
| 1655 | (dolist (before befores) |
|---|
| 1656 | (funcall (%method-function before) args nil)) |
|---|
| 1657 | (multiple-value-prog1 |
|---|
| 1658 | (funcall method-function args next-emfun) |
|---|
| 1659 | (dolist (after reverse-afters) |
|---|
| 1660 | (funcall (%method-function after) args nil)))))))))) |
|---|
| 1661 | (t |
|---|
| 1662 | (let ((mc-obj (get mc-name 'method-combination-object))) |
|---|
| 1663 | (unless mc-obj |
|---|
| 1664 | (error "Unsupported method combination type ~A." mc-name)) |
|---|
| 1665 | (let* ((operator (method-combination-operator mc-obj)) |
|---|
| 1666 | (ioa (method-combination-identity-with-one-argument mc-obj))) |
|---|
| 1667 | (setf emf-form |
|---|
| 1668 | (if (and (null (cdr primaries)) |
|---|
| 1669 | (not (null ioa))) |
|---|
| 1670 | ;; `(lambda (args) |
|---|
| 1671 | ;; (funcall ,(%method-function (car primaries)) args nil)) |
|---|
| 1672 | (generate-emf-lambda (%method-function (car primaries)) nil) |
|---|
| 1673 | `(lambda (args) |
|---|
| 1674 | (,operator ,@(mapcar |
|---|
| 1675 | (lambda (primary) |
|---|
| 1676 | `(funcall ,(%method-function primary) args nil)) |
|---|
| 1677 | primaries))))))))) |
|---|
| 1678 | (or (ignore-errors (autocompile emf-form)) |
|---|
| 1679 | (coerce-to-function emf-form)))) |
|---|
| 1680 | |
|---|
| 1681 | (defun generate-emf-lambda (method-function next-emfun) |
|---|
| 1682 | #'(lambda (args) |
|---|
| 1683 | (declare (optimize speed)) |
|---|
| 1684 | (funcall method-function args next-emfun))) |
|---|
| 1685 | |
|---|
| 1686 | ;;; compute an effective method function from a list of primary methods: |
|---|
| 1687 | |
|---|
| 1688 | (defun compute-primary-emfun (methods) |
|---|
| 1689 | (if (null methods) |
|---|
| 1690 | nil |
|---|
| 1691 | (let ((next-emfun (compute-primary-emfun (cdr methods)))) |
|---|
| 1692 | #'(lambda (args) |
|---|
| 1693 | (funcall (%method-function (car methods)) args next-emfun))))) |
|---|
| 1694 | |
|---|
| 1695 | (defvar *call-next-method-p*) |
|---|
| 1696 | (defvar *next-method-p-p*) |
|---|
| 1697 | |
|---|
| 1698 | (defun walk-form (form) |
|---|
| 1699 | (cond ((atom form) |
|---|
| 1700 | (cond ((eq form 'call-next-method) |
|---|
| 1701 | (setf *call-next-method-p* t)) |
|---|
| 1702 | ((eq form 'next-method-p) |
|---|
| 1703 | (setf *next-method-p-p* t)))) |
|---|
| 1704 | (t |
|---|
| 1705 | (walk-form (%car form)) |
|---|
| 1706 | (walk-form (%cdr form))))) |
|---|
| 1707 | |
|---|
| 1708 | (defun compute-method-function (lambda-expression) |
|---|
| 1709 | (let ((lambda-list (allow-other-keys (cadr lambda-expression))) |
|---|
| 1710 | (body (cddr lambda-expression)) |
|---|
| 1711 | (*call-next-method-p* nil) |
|---|
| 1712 | (*next-method-p-p* nil)) |
|---|
| 1713 | (multiple-value-bind (body declarations) (parse-body body) |
|---|
| 1714 | (let ((ignorable-vars '())) |
|---|
| 1715 | (dolist (var lambda-list) |
|---|
| 1716 | (if (memq var lambda-list-keywords) |
|---|
| 1717 | (return) |
|---|
| 1718 | (push var ignorable-vars))) |
|---|
| 1719 | (push `(declare (ignorable ,@ignorable-vars)) declarations)) |
|---|
| 1720 | (walk-form body) |
|---|
| 1721 | (cond ((or *call-next-method-p* *next-method-p-p*) |
|---|
| 1722 | `(lambda (args next-emfun) |
|---|
| 1723 | (flet ((call-next-method (&rest cnm-args) |
|---|
| 1724 | (if (null next-emfun) |
|---|
| 1725 | (error "No next method for generic function.") |
|---|
| 1726 | (funcall next-emfun (or cnm-args args)))) |
|---|
| 1727 | (next-method-p () |
|---|
| 1728 | (not (null next-emfun)))) |
|---|
| 1729 | (declare (ignorable (function call-next-method) |
|---|
| 1730 | (function next-method-p))) |
|---|
| 1731 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))) |
|---|
| 1732 | ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) |
|---|
| 1733 | ;; Required parameters only. |
|---|
| 1734 | (case (length lambda-list) |
|---|
| 1735 | (1 |
|---|
| 1736 | `(lambda (args next-emfun) |
|---|
| 1737 | (declare (ignore next-emfun)) |
|---|
| 1738 | (let ((,(%car lambda-list) (%car args))) |
|---|
| 1739 | (declare (ignorable ,(%car lambda-list))) |
|---|
| 1740 | ,@declarations ,@body))) |
|---|
| 1741 | (2 |
|---|
| 1742 | `(lambda (args next-emfun) |
|---|
| 1743 | (declare (ignore next-emfun)) |
|---|
| 1744 | (let ((,(%car lambda-list) (%car args)) |
|---|
| 1745 | (,(%cadr lambda-list) (%cadr args))) |
|---|
| 1746 | (declare (ignorable ,(%car lambda-list) |
|---|
| 1747 | ,(%cadr lambda-list))) |
|---|
| 1748 | ,@declarations ,@body))) |
|---|
| 1749 | (3 |
|---|
| 1750 | `(lambda (args next-emfun) |
|---|
| 1751 | (declare (ignore next-emfun)) |
|---|
| 1752 | (let ((,(%car lambda-list) (%car args)) |
|---|
| 1753 | (,(%cadr lambda-list) (%cadr args)) |
|---|
| 1754 | (,(%caddr lambda-list) (%caddr args))) |
|---|
| 1755 | (declare (ignorable ,(%car lambda-list) |
|---|
| 1756 | ,(%cadr lambda-list) |
|---|
| 1757 | ,(%caddr lambda-list))) |
|---|
| 1758 | ,@declarations ,@body))) |
|---|
| 1759 | (t |
|---|
| 1760 | `(lambda (args next-emfun) |
|---|
| 1761 | (declare (ignore next-emfun)) |
|---|
| 1762 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))) |
|---|
| 1763 | (t |
|---|
| 1764 | `(lambda (args next-emfun) |
|---|
| 1765 | (declare (ignore next-emfun)) |
|---|
| 1766 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))))) |
|---|
| 1767 | |
|---|
| 1768 | (defun compute-method-fast-function (lambda-expression) |
|---|
| 1769 | (let ((lambda-list (allow-other-keys (cadr lambda-expression)))) |
|---|
| 1770 | (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)) |
|---|
| 1771 | (return-from compute-method-fast-function nil)) |
|---|
| 1772 | ;; Only required args. |
|---|
| 1773 | (let ((body (cddr lambda-expression)) |
|---|
| 1774 | (*call-next-method-p* nil) |
|---|
| 1775 | (*next-method-p-p* nil)) |
|---|
| 1776 | (multiple-value-bind (body declarations) (parse-body body) |
|---|
| 1777 | (walk-form body) |
|---|
| 1778 | (when (or *call-next-method-p* *next-method-p-p*) |
|---|
| 1779 | (return-from compute-method-fast-function nil)) |
|---|
| 1780 | (let ((decls `(declare (ignorable ,@lambda-list)))) |
|---|
| 1781 | (setf lambda-expression |
|---|
| 1782 | (list* (car lambda-expression) |
|---|
| 1783 | (cadr lambda-expression) |
|---|
| 1784 | decls |
|---|
| 1785 | (cddr lambda-expression)))) |
|---|
| 1786 | (case (length lambda-list) |
|---|
| 1787 | (1 |
|---|
| 1788 | ;; `(lambda (args next-emfun) |
|---|
| 1789 | ;; (let ((,(%car lambda-list) (%car args))) |
|---|
| 1790 | ;; (declare (ignorable ,(%car lambda-list))) |
|---|
| 1791 | ;; ,@declarations ,@body))) |
|---|
| 1792 | lambda-expression) |
|---|
| 1793 | (2 |
|---|
| 1794 | ;; `(lambda (args next-emfun) |
|---|
| 1795 | ;; (let ((,(%car lambda-list) (%car args)) |
|---|
| 1796 | ;; (,(%cadr lambda-list) (%cadr args))) |
|---|
| 1797 | ;; (declare (ignorable ,(%car lambda-list) |
|---|
| 1798 | ;; ,(%cadr lambda-list))) |
|---|
| 1799 | ;; ,@declarations ,@body))) |
|---|
| 1800 | lambda-expression) |
|---|
| 1801 | ;; (3 |
|---|
| 1802 | ;; `(lambda (args next-emfun) |
|---|
| 1803 | ;; (let ((,(%car lambda-list) (%car args)) |
|---|
| 1804 | ;; (,(%cadr lambda-list) (%cadr args)) |
|---|
| 1805 | ;; (,(%caddr lambda-list) (%caddr args))) |
|---|
| 1806 | ;; (declare (ignorable ,(%car lambda-list) |
|---|
| 1807 | ;; ,(%cadr lambda-list) |
|---|
| 1808 | ;; ,(%caddr lambda-list))) |
|---|
| 1809 | ;; ,@declarations ,@body))) |
|---|
| 1810 | (t |
|---|
| 1811 | nil)))))) |
|---|
| 1812 | |
|---|
| 1813 | ;; From CLHS section 7.6.5: |
|---|
| 1814 | ;; "When a generic function or any of its methods mentions &key in a lambda |
|---|
| 1815 | ;; list, the specific set of keyword arguments accepted by the generic function |
|---|
| 1816 | ;; varies according to the applicable methods. The set of keyword arguments |
|---|
| 1817 | ;; accepted by the generic function for a particular call is the union of the |
|---|
| 1818 | ;; keyword arguments accepted by all applicable methods and the keyword |
|---|
| 1819 | ;; arguments mentioned after &key in the generic function definition, if any." |
|---|
| 1820 | ;; Adapted from Sacla. |
|---|
| 1821 | (defun allow-other-keys (lambda-list) |
|---|
| 1822 | (if (and (member '&key lambda-list) |
|---|
| 1823 | (not (member '&allow-other-keys lambda-list))) |
|---|
| 1824 | (let* ((key-end (or (position '&aux lambda-list) (length lambda-list))) |
|---|
| 1825 | (aux-part (subseq lambda-list key-end))) |
|---|
| 1826 | `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part)) |
|---|
| 1827 | lambda-list)) |
|---|
| 1828 | |
|---|
| 1829 | (defmacro defmethod (&rest args) |
|---|
| 1830 | (multiple-value-bind |
|---|
| 1831 | (function-name qualifiers lambda-list specializers documentation declarations body) |
|---|
| 1832 | (parse-defmethod args) |
|---|
| 1833 | (let* ((specializers-form '()) |
|---|
| 1834 | (lambda-expression `(lambda ,lambda-list ,@declarations ,body)) |
|---|
| 1835 | (method-function (compute-method-function lambda-expression)) |
|---|
| 1836 | (fast-function (compute-method-fast-function lambda-expression)) |
|---|
| 1837 | ) |
|---|
| 1838 | (dolist (specializer specializers) |
|---|
| 1839 | (cond ((and (consp specializer) (eq (car specializer) 'eql)) |
|---|
| 1840 | (push `(list 'eql ,(cadr specializer)) specializers-form)) |
|---|
| 1841 | (t |
|---|
| 1842 | (push `',specializer specializers-form)))) |
|---|
| 1843 | (setf specializers-form `(list ,@(nreverse specializers-form))) |
|---|
| 1844 | `(progn |
|---|
| 1845 | (ensure-method ',function-name |
|---|
| 1846 | :lambda-list ',lambda-list |
|---|
| 1847 | :qualifiers ',qualifiers |
|---|
| 1848 | :specializers ,specializers-form |
|---|
| 1849 | ,@(if documentation `(:documentation ,documentation)) |
|---|
| 1850 | :function (function ,method-function) |
|---|
| 1851 | ,@(if fast-function `(:fast-function (function ,fast-function))) |
|---|
| 1852 | ))))) |
|---|
| 1853 | |
|---|
| 1854 | ;;; Reader and writer methods |
|---|
| 1855 | |
|---|
| 1856 | (defun make-instance-standard-reader-method (gf |
|---|
| 1857 | &key |
|---|
| 1858 | lambda-list |
|---|
| 1859 | qualifiers |
|---|
| 1860 | specializers |
|---|
| 1861 | documentation |
|---|
| 1862 | function |
|---|
| 1863 | fast-function |
|---|
| 1864 | slot-name) |
|---|
| 1865 | (declare (ignore gf)) |
|---|
| 1866 | (let ((method (std-allocate-instance +the-standard-reader-method-class+))) |
|---|
| 1867 | (setf (method-lambda-list method) lambda-list) |
|---|
| 1868 | (setf (method-qualifiers method) qualifiers) |
|---|
| 1869 | (%set-method-specializers method (canonicalize-specializers specializers)) |
|---|
| 1870 | (setf (method-documentation method) documentation) |
|---|
| 1871 | (%set-method-generic-function method nil) |
|---|
| 1872 | (%set-method-function method function) |
|---|
| 1873 | (%set-method-fast-function method fast-function) |
|---|
| 1874 | (set-reader-method-slot-name method slot-name) |
|---|
| 1875 | method)) |
|---|
| 1876 | |
|---|
| 1877 | (defun add-reader-method (class function-name slot-name) |
|---|
| 1878 | (let* ((lambda-expression |
|---|
| 1879 | (if (eq (class-of class) +the-standard-class+) |
|---|
| 1880 | `(lambda (object) (std-slot-value object ',slot-name)) |
|---|
| 1881 | `(lambda (object) (slot-value object ',slot-name)))) |
|---|
| 1882 | (method-function (compute-method-function lambda-expression)) |
|---|
| 1883 | (fast-function (compute-method-fast-function lambda-expression))) |
|---|
| 1884 | (let ((method-lambda-list '(object)) |
|---|
| 1885 | (gf (find-generic-function function-name nil))) |
|---|
| 1886 | (if gf |
|---|
| 1887 | (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) |
|---|
| 1888 | (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list))) |
|---|
| 1889 | (let ((method |
|---|
| 1890 | (make-instance-standard-reader-method gf |
|---|
| 1891 | :lambda-list '(object) |
|---|
| 1892 | :qualifiers () |
|---|
| 1893 | :specializers (list class) |
|---|
| 1894 | :function (if (autoloadp 'compile) |
|---|
| 1895 | method-function |
|---|
| 1896 | (autocompile method-function)) |
|---|
| 1897 | :fast-function (if (autoloadp 'compile) |
|---|
| 1898 | fast-function |
|---|
| 1899 | (autocompile fast-function)) |
|---|
| 1900 | :slot-name slot-name))) |
|---|
| 1901 | (%add-method gf method) |
|---|
| 1902 | method)))) |
|---|
| 1903 | |
|---|
| 1904 | (defun add-writer-method (class function-name slot-name) |
|---|
| 1905 | (let* ((lambda-expression |
|---|
| 1906 | (if (eq (class-of class) +the-standard-class+) |
|---|
| 1907 | `(lambda (new-value object) |
|---|
| 1908 | (setf (std-slot-value object ',slot-name) new-value)) |
|---|
| 1909 | `(lambda (new-value object) |
|---|
| 1910 | (setf (slot-value object ',slot-name) new-value)))) |
|---|
| 1911 | (method-function (compute-method-function lambda-expression)) |
|---|
| 1912 | (fast-function (compute-method-fast-function lambda-expression)) |
|---|
| 1913 | ) |
|---|
| 1914 | (ensure-method function-name |
|---|
| 1915 | :lambda-list '(new-value object) |
|---|
| 1916 | :qualifiers () |
|---|
| 1917 | :specializers (list +the-T-class+ class) |
|---|
| 1918 | ;; :function `(function ,method-function) |
|---|
| 1919 | :function (if (autoloadp 'compile) |
|---|
| 1920 | method-function |
|---|
| 1921 | (autocompile method-function)) |
|---|
| 1922 | :fast-function (if (autoloadp 'compile) |
|---|
| 1923 | fast-function |
|---|
| 1924 | (autocompile fast-function)) |
|---|
| 1925 | ))) |
|---|
| 1926 | |
|---|
| 1927 | (defmacro redefine-class-forwarder (name slot &optional alternative-name) |
|---|
| 1928 | (let* (($name (if (consp name) (cadr name) name)) |
|---|
| 1929 | (%name (intern (concatenate 'string |
|---|
| 1930 | "%" |
|---|
| 1931 | (if (consp name) |
|---|
| 1932 | (symbol-name 'set-) "") |
|---|
| 1933 | (symbol-name $name)) |
|---|
| 1934 | (find-package "SYS")))) |
|---|
| 1935 | (unless alternative-name |
|---|
| 1936 | (setf alternative-name name)) |
|---|
| 1937 | (if (consp name) |
|---|
| 1938 | `(progn ;; setter |
|---|
| 1939 | (defgeneric ,alternative-name (new-value class)) |
|---|
| 1940 | (defmethod ,alternative-name (new-value (class built-in-class)) |
|---|
| 1941 | (,%name new-value class)) |
|---|
| 1942 | (defmethod ,alternative-name (new-value (class forward-referenced-class)) |
|---|
| 1943 | (,%name new-value class)) |
|---|
| 1944 | (defmethod ,alternative-name (new-value (class structure-class)) |
|---|
| 1945 | (,%name new-value class)) |
|---|
| 1946 | (defmethod ,alternative-name (new-value (class standard-class)) |
|---|
| 1947 | (setf (slot-value class ',slot) new-value)) |
|---|
| 1948 | ,@(unless (eq name alternative-name) |
|---|
| 1949 | `((setf (get ',$name 'SETF-FUNCTION) |
|---|
| 1950 | (symbol-function ',alternative-name)))) |
|---|
| 1951 | ) |
|---|
| 1952 | `(progn ;; getter |
|---|
| 1953 | (defgeneric ,alternative-name (class)) |
|---|
| 1954 | (defmethod ,alternative-name ((class built-in-class)) |
|---|
| 1955 | (,%name class)) |
|---|
| 1956 | (defmethod ,alternative-name ((class forward-referenced-class)) |
|---|
| 1957 | (,%name class)) |
|---|
| 1958 | (defmethod ,alternative-name ((class structure-class)) |
|---|
| 1959 | (,%name class)) |
|---|
| 1960 | (defmethod ,alternative-name ((class standard-class)) |
|---|
| 1961 | (slot-value class ',slot)) |
|---|
| 1962 | ,@(unless (eq name alternative-name) |
|---|
| 1963 | `((setf (symbol-function ',$name) |
|---|
| 1964 | (symbol-function ',alternative-name)))) |
|---|
| 1965 | ) ))) |
|---|
| 1966 | |
|---|
| 1967 | (redefine-class-forwarder class-name name) |
|---|
| 1968 | (redefine-class-forwarder (setf class-name) name) |
|---|
| 1969 | (redefine-class-forwarder class-slots slots) |
|---|
| 1970 | (redefine-class-forwarder (setf class-slots) slots) |
|---|
| 1971 | (redefine-class-forwarder class-direct-slots direct-slots) |
|---|
| 1972 | (redefine-class-forwarder (setf class-direct-slots) direct-slots) |
|---|
| 1973 | (redefine-class-forwarder class-layout layout) |
|---|
| 1974 | (redefine-class-forwarder (setf class-layout) layout) |
|---|
| 1975 | (redefine-class-forwarder class-direct-superclasses direct-superclasses) |
|---|
| 1976 | (redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses) |
|---|
| 1977 | (redefine-class-forwarder class-direct-subclasses direct-subclasses) |
|---|
| 1978 | (redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses) |
|---|
| 1979 | (redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods) |
|---|
| 1980 | (redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods) |
|---|
| 1981 | (redefine-class-forwarder class-precedence-list precedence-list) |
|---|
| 1982 | (redefine-class-forwarder (setf class-precedence-list) precedence-list) |
|---|
| 1983 | (redefine-class-forwarder class-finalized-p finalized-p) |
|---|
| 1984 | (redefine-class-forwarder (setf class-finalized-p) finalized-p) |
|---|
| 1985 | (redefine-class-forwarder class-default-initargs default-initargs) |
|---|
| 1986 | (redefine-class-forwarder (setf class-default-initargs) default-initargs) |
|---|
| 1987 | (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) |
|---|
| 1988 | (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) |
|---|
| 1989 | |
|---|
| 1990 | (defgeneric direct-slot-definition-class (class &rest initargs)) |
|---|
| 1991 | |
|---|
| 1992 | (defmethod direct-slot-definition-class ((class class) &rest initargs) |
|---|
| 1993 | (declare (ignore initargs)) |
|---|
| 1994 | +the-direct-slot-definition-class+) |
|---|
| 1995 | |
|---|
| 1996 | (defgeneric effective-slot-definition-class (class &rest initargs)) |
|---|
| 1997 | |
|---|
| 1998 | (defmethod effective-slot-definition-class ((class class) &rest initargs) |
|---|
| 1999 | (declare (ignore initargs)) |
|---|
| 2000 | +the-effective-slot-definition-class+) |
|---|
| 2001 | |
|---|
| 2002 | (fmakunbound 'documentation) |
|---|
| 2003 | (defgeneric documentation (x doc-type)) |
|---|
| 2004 | |
|---|
| 2005 | (defgeneric (setf documentation) (new-value x doc-type)) |
|---|
| 2006 | |
|---|
| 2007 | (defmethod documentation ((x symbol) doc-type) |
|---|
| 2008 | (%documentation x doc-type)) |
|---|
| 2009 | |
|---|
| 2010 | (defmethod (setf documentation) (new-value (x symbol) doc-type) |
|---|
| 2011 | (%set-documentation x doc-type new-value)) |
|---|
| 2012 | |
|---|
| 2013 | (defmethod documentation ((x function) doc-type) |
|---|
| 2014 | (%documentation x doc-type)) |
|---|
| 2015 | |
|---|
| 2016 | (defmethod (setf documentation) (new-value (x function) doc-type) |
|---|
| 2017 | (%set-documentation x doc-type new-value)) |
|---|
| 2018 | |
|---|
| 2019 | ;; FIXME This should be a weak hashtable! |
|---|
| 2020 | (defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) |
|---|
| 2021 | |
|---|
| 2022 | (defmethod documentation ((x list) (doc-type (eql 'function))) |
|---|
| 2023 | (let ((alist (gethash x *list-documentation-hashtable*))) |
|---|
| 2024 | (and alist (cdr (assoc doc-type alist))))) |
|---|
| 2025 | |
|---|
| 2026 | (defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) |
|---|
| 2027 | (let ((alist (gethash x *list-documentation-hashtable*))) |
|---|
| 2028 | (and alist (cdr (assoc doc-type alist))))) |
|---|
| 2029 | |
|---|
| 2030 | (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) |
|---|
| 2031 | (let* ((alist (gethash x *list-documentation-hashtable*)) |
|---|
| 2032 | (entry (and alist (assoc doc-type alist)))) |
|---|
| 2033 | (cond (entry |
|---|
| 2034 | (setf (cdr entry) new-value)) |
|---|
| 2035 | (t |
|---|
| 2036 | (setf (gethash x *list-documentation-hashtable*) |
|---|
| 2037 | (push (cons doc-type new-value) alist))))) |
|---|
| 2038 | new-value) |
|---|
| 2039 | |
|---|
| 2040 | (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) |
|---|
| 2041 | (let* ((alist (gethash x *list-documentation-hashtable*)) |
|---|
| 2042 | (entry (and alist (assoc doc-type alist)))) |
|---|
| 2043 | (cond (entry |
|---|
| 2044 | (setf (cdr entry) new-value)) |
|---|
| 2045 | (t |
|---|
| 2046 | (setf (gethash x *list-documentation-hashtable*) |
|---|
| 2047 | (push (cons doc-type new-value) alist))))) |
|---|
| 2048 | new-value) |
|---|
| 2049 | |
|---|
| 2050 | (defmethod documentation ((x standard-class) (doc-type (eql 't))) |
|---|
| 2051 | (class-documentation x)) |
|---|
| 2052 | |
|---|
| 2053 | (defmethod documentation ((x standard-class) (doc-type (eql 'type))) |
|---|
| 2054 | (class-documentation x)) |
|---|
| 2055 | |
|---|
| 2056 | (defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't))) |
|---|
| 2057 | (%set-class-documentation x new-value)) |
|---|
| 2058 | |
|---|
| 2059 | (defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type))) |
|---|
| 2060 | (%set-class-documentation x new-value)) |
|---|
| 2061 | |
|---|
| 2062 | (defmethod documentation ((x structure-class) (doc-type (eql 't))) |
|---|
| 2063 | (%documentation x doc-type)) |
|---|
| 2064 | |
|---|
| 2065 | (defmethod documentation ((x structure-class) (doc-type (eql 'type))) |
|---|
| 2066 | (%documentation x doc-type)) |
|---|
| 2067 | |
|---|
| 2068 | (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) |
|---|
| 2069 | (%set-documentation x doc-type new-value)) |
|---|
| 2070 | |
|---|
| 2071 | (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) |
|---|
| 2072 | (%set-documentation x doc-type new-value)) |
|---|
| 2073 | |
|---|
| 2074 | (defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) |
|---|
| 2075 | (generic-function-documentation x)) |
|---|
| 2076 | |
|---|
| 2077 | (defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't))) |
|---|
| 2078 | (setf (generic-function-documentation x) new-value)) |
|---|
| 2079 | |
|---|
| 2080 | (defmethod documentation ((x standard-generic-function) (doc-type (eql 'function))) |
|---|
| 2081 | (generic-function-documentation x)) |
|---|
| 2082 | |
|---|
| 2083 | (defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function))) |
|---|
| 2084 | (setf (generic-function-documentation x) new-value)) |
|---|
| 2085 | |
|---|
| 2086 | (defmethod documentation ((x standard-method) (doc-type (eql 't))) |
|---|
| 2087 | (method-documentation x)) |
|---|
| 2088 | |
|---|
| 2089 | (defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) |
|---|
| 2090 | (setf (method-documentation x) new-value)) |
|---|
| 2091 | |
|---|
| 2092 | (defmethod documentation ((x package) (doc-type (eql 't))) |
|---|
| 2093 | (%documentation x doc-type)) |
|---|
| 2094 | |
|---|
| 2095 | (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) |
|---|
| 2096 | (%set-documentation x doc-type new-value)) |
|---|
| 2097 | |
|---|
| 2098 | ;;; Applicable methods |
|---|
| 2099 | |
|---|
| 2100 | (defgeneric compute-applicable-methods (gf args) |
|---|
| 2101 | (:method ((gf standard-generic-function) args) |
|---|
| 2102 | (%compute-applicable-methods gf args))) |
|---|
| 2103 | |
|---|
| 2104 | (defgeneric compute-applicable-methods-using-classes (gf classes) |
|---|
| 2105 | (:method ((gf standard-generic-function) classes) |
|---|
| 2106 | (let ((methods '())) |
|---|
| 2107 | (dolist (method (generic-function-methods gf)) |
|---|
| 2108 | (multiple-value-bind (applicable knownp) |
|---|
| 2109 | (method-applicable-using-classes-p method classes) |
|---|
| 2110 | (cond (applicable |
|---|
| 2111 | (push method methods)) |
|---|
| 2112 | ((not knownp) |
|---|
| 2113 | (return-from compute-applicable-methods-using-classes |
|---|
| 2114 | (values nil nil)))))) |
|---|
| 2115 | (values (sort-methods methods gf classes) |
|---|
| 2116 | t)))) |
|---|
| 2117 | |
|---|
| 2118 | (export '(compute-applicable-methods |
|---|
| 2119 | compute-applicable-methods-using-classes)) |
|---|
| 2120 | |
|---|
| 2121 | |
|---|
| 2122 | ;;; Slot access |
|---|
| 2123 | |
|---|
| 2124 | (defun set-slot-value-using-class (new-value class instance slot-name) |
|---|
| 2125 | (declare (ignore class)) ; FIXME |
|---|
| 2126 | (setf (std-slot-value instance slot-name) new-value)) |
|---|
| 2127 | |
|---|
| 2128 | (defgeneric slot-value-using-class (class instance slot-name)) |
|---|
| 2129 | |
|---|
| 2130 | (defmethod slot-value-using-class ((class standard-class) instance slot-name) |
|---|
| 2131 | (std-slot-value instance slot-name)) |
|---|
| 2132 | |
|---|
| 2133 | (defmethod slot-value-using-class ((class structure-class) instance slot-name) |
|---|
| 2134 | (std-slot-value instance slot-name)) |
|---|
| 2135 | |
|---|
| 2136 | (defgeneric (setf slot-value-using-class) (new-value class instance slot-name)) |
|---|
| 2137 | |
|---|
| 2138 | (defmethod (setf slot-value-using-class) (new-value |
|---|
| 2139 | (class standard-class) |
|---|
| 2140 | instance |
|---|
| 2141 | slot-name) |
|---|
| 2142 | (setf (std-slot-value instance slot-name) new-value)) |
|---|
| 2143 | |
|---|
| 2144 | (defmethod (setf slot-value-using-class) (new-value |
|---|
| 2145 | (class structure-class) |
|---|
| 2146 | instance |
|---|
| 2147 | slot-name) |
|---|
| 2148 | (setf (std-slot-value instance slot-name) new-value)) |
|---|
| 2149 | |
|---|
| 2150 | (defgeneric slot-exists-p-using-class (class instance slot-name)) |
|---|
| 2151 | |
|---|
| 2152 | (defmethod slot-exists-p-using-class (class instance slot-name) |
|---|
| 2153 | nil) |
|---|
| 2154 | |
|---|
| 2155 | (defmethod slot-exists-p-using-class ((class standard-class) instance slot-name) |
|---|
| 2156 | (std-slot-exists-p instance slot-name)) |
|---|
| 2157 | |
|---|
| 2158 | (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) |
|---|
| 2159 | (dolist (dsd (class-slots class)) |
|---|
| 2160 | (when (eq (sys::dsd-name dsd) slot-name) |
|---|
| 2161 | (return-from slot-exists-p-using-class t))) |
|---|
| 2162 | nil) |
|---|
| 2163 | |
|---|
| 2164 | (defgeneric slot-boundp-using-class (class instance slot-name)) |
|---|
| 2165 | (defmethod slot-boundp-using-class ((class standard-class) instance slot-name) |
|---|
| 2166 | (std-slot-boundp instance slot-name)) |
|---|
| 2167 | (defmethod slot-boundp-using-class ((class structure-class) instance slot-name) |
|---|
| 2168 | "Structure slots can't be unbound, so this method always returns T." |
|---|
| 2169 | (declare (ignore class instance slot-name)) |
|---|
| 2170 | t) |
|---|
| 2171 | |
|---|
| 2172 | (defgeneric slot-makunbound-using-class (class instance slot-name)) |
|---|
| 2173 | (defmethod slot-makunbound-using-class ((class standard-class) |
|---|
| 2174 | instance |
|---|
| 2175 | slot-name) |
|---|
| 2176 | (std-slot-makunbound instance slot-name)) |
|---|
| 2177 | (defmethod slot-makunbound-using-class ((class structure-class) |
|---|
| 2178 | instance |
|---|
| 2179 | slot-name) |
|---|
| 2180 | (declare (ignore class instance slot-name)) |
|---|
| 2181 | (error "Structure slots can't be unbound")) |
|---|
| 2182 | |
|---|
| 2183 | (defgeneric slot-missing (class instance slot-name operation &optional new-value)) |
|---|
| 2184 | |
|---|
| 2185 | (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) |
|---|
| 2186 | (declare (ignore new-value)) |
|---|
| 2187 | (error "The slot ~S is missing from the class ~S." slot-name class)) |
|---|
| 2188 | |
|---|
| 2189 | (defgeneric slot-unbound (class instance slot-name)) |
|---|
| 2190 | |
|---|
| 2191 | (defmethod slot-unbound ((class t) instance slot-name) |
|---|
| 2192 | (error 'unbound-slot :instance instance :name slot-name)) |
|---|
| 2193 | |
|---|
| 2194 | ;;; Instance creation and initialization |
|---|
| 2195 | |
|---|
| 2196 | (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) |
|---|
| 2197 | |
|---|
| 2198 | (defmethod allocate-instance ((class standard-class) &rest initargs) |
|---|
| 2199 | (declare (ignore initargs)) |
|---|
| 2200 | (std-allocate-instance class)) |
|---|
| 2201 | |
|---|
| 2202 | (defmethod allocate-instance ((class structure-class) &rest initargs) |
|---|
| 2203 | (declare (ignore initargs)) |
|---|
| 2204 | (%make-structure (class-name class) |
|---|
| 2205 | (make-list (length (class-slots class)) |
|---|
| 2206 | :initial-element +slot-unbound+))) |
|---|
| 2207 | |
|---|
| 2208 | ;; "The set of valid initialization arguments for a class is the set of valid |
|---|
| 2209 | ;; initialization arguments that either fill slots or supply arguments to |
|---|
| 2210 | ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." |
|---|
| 2211 | ;; 7.1.2 |
|---|
| 2212 | |
|---|
| 2213 | (defun check-initargs (instance shared-initialize-param initargs) |
|---|
| 2214 | (when (oddp (length initargs)) |
|---|
| 2215 | (error 'program-error |
|---|
| 2216 | :format-control "Odd number of keyword arguments.")) |
|---|
| 2217 | (unless (getf initargs :allow-other-keys) |
|---|
| 2218 | (let ((methods |
|---|
| 2219 | (nconc |
|---|
| 2220 | (compute-applicable-methods |
|---|
| 2221 | #'shared-initialize |
|---|
| 2222 | (if initargs |
|---|
| 2223 | `(,instance ,shared-initialize-param ,@initargs) |
|---|
| 2224 | (list instance shared-initialize-param))) |
|---|
| 2225 | (compute-applicable-methods |
|---|
| 2226 | #'initialize-instance |
|---|
| 2227 | (if initargs |
|---|
| 2228 | `(,instance ,@initargs) |
|---|
| 2229 | (list instance))))) |
|---|
| 2230 | (slots (class-slots (class-of instance)))) |
|---|
| 2231 | (do* ((tail initargs (cddr tail)) |
|---|
| 2232 | (initarg (car tail) (car tail))) |
|---|
| 2233 | ((null tail)) |
|---|
| 2234 | (unless (or (valid-initarg-p initarg slots) |
|---|
| 2235 | (valid-methodarg-p initarg methods) |
|---|
| 2236 | (eq initarg :allow-other-keys)) |
|---|
| 2237 | (error 'program-error |
|---|
| 2238 | :format-control "Invalid initarg ~S." |
|---|
| 2239 | :format-arguments (list initarg))))))) |
|---|
| 2240 | |
|---|
| 2241 | (defun valid-methodarg-p (initarg methods) |
|---|
| 2242 | (when (symbolp initarg) |
|---|
| 2243 | (dolist (method methods nil) |
|---|
| 2244 | (let ((valid-initargs (method-lambda-list method))) |
|---|
| 2245 | (when (find (symbol-value initarg) valid-initargs |
|---|
| 2246 | :test #'(lambda (a b) |
|---|
| 2247 | (if (listp b) |
|---|
| 2248 | (string= a (car b)) |
|---|
| 2249 | (or |
|---|
| 2250 | (string= a b) |
|---|
| 2251 | (string= b "&ALLOW-OTHER-KEYS"))))) |
|---|
| 2252 | |
|---|
| 2253 | (return t)))))) |
|---|
| 2254 | |
|---|
| 2255 | (defun valid-initarg-p (initarg slots) |
|---|
| 2256 | (dolist (slot slots nil) |
|---|
| 2257 | (let ((valid-initargs (slot-definition-initargs slot))) |
|---|
| 2258 | (when (memq initarg valid-initargs) |
|---|
| 2259 | (return t))))) |
|---|
| 2260 | |
|---|
| 2261 | (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) |
|---|
| 2262 | |
|---|
| 2263 | (defmethod make-instance ((class standard-class) &rest initargs) |
|---|
| 2264 | (when (oddp (length initargs)) |
|---|
| 2265 | (error 'program-error :format-control "Odd number of keyword arguments.")) |
|---|
| 2266 | (unless (class-finalized-p class) |
|---|
| 2267 | (std-finalize-inheritance class)) |
|---|
| 2268 | (let ((class-default-initargs (class-default-initargs class))) |
|---|
| 2269 | (when class-default-initargs |
|---|
| 2270 | (let ((default-initargs '())) |
|---|
| 2271 | (do* ((list class-default-initargs (cddr list)) |
|---|
| 2272 | (key (car list) (car list)) |
|---|
| 2273 | (fn (cadr list) (cadr list))) |
|---|
| 2274 | ((null list)) |
|---|
| 2275 | (when (eq (getf initargs key 'not-found) 'not-found) |
|---|
| 2276 | (setf default-initargs (append default-initargs (list key (funcall fn)))))) |
|---|
| 2277 | (setf initargs (append initargs default-initargs))))) |
|---|
| 2278 | |
|---|
| 2279 | (let ((instance (std-allocate-instance class))) |
|---|
| 2280 | (check-initargs instance t initargs) |
|---|
| 2281 | (apply #'initialize-instance instance initargs) |
|---|
| 2282 | instance)) |
|---|
| 2283 | |
|---|
| 2284 | (defmethod make-instance ((class symbol) &rest initargs) |
|---|
| 2285 | (apply #'make-instance (find-class class) initargs)) |
|---|
| 2286 | |
|---|
| 2287 | (defgeneric initialize-instance (instance &key)) |
|---|
| 2288 | |
|---|
| 2289 | (defmethod initialize-instance ((instance standard-object) &rest initargs) |
|---|
| 2290 | (apply #'shared-initialize instance t initargs)) |
|---|
| 2291 | |
|---|
| 2292 | (defgeneric reinitialize-instance (instance &key)) |
|---|
| 2293 | |
|---|
| 2294 | ;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the |
|---|
| 2295 | ;; validity of initargs and signals an error if an initarg is supplied that is |
|---|
| 2296 | ;; not declared as valid. The method then calls the generic function SHARED- |
|---|
| 2297 | ;; INITIALIZE with the following arguments: the instance, nil (which means no |
|---|
| 2298 | ;; slots should be initialized according to their initforms), and the initargs |
|---|
| 2299 | ;; it received." |
|---|
| 2300 | (defmethod reinitialize-instance ((instance standard-object) &rest initargs) |
|---|
| 2301 | (apply #'shared-initialize instance () initargs)) |
|---|
| 2302 | |
|---|
| 2303 | (defun std-shared-initialize (instance slot-names all-keys) |
|---|
| 2304 | (when (oddp (length all-keys)) |
|---|
| 2305 | (error 'program-error :format-control "Odd number of keyword arguments.")) |
|---|
| 2306 | (do* ((tail all-keys (cddr tail)) |
|---|
| 2307 | (initarg (car tail) (car tail))) |
|---|
| 2308 | ((null tail)) |
|---|
| 2309 | (when (and initarg (not (symbolp initarg))) |
|---|
| 2310 | (error 'program-error |
|---|
| 2311 | :format-control "Invalid initarg ~S." |
|---|
| 2312 | :format-arguments (list initarg)))) |
|---|
| 2313 | (dolist (slot (class-slots (class-of instance))) |
|---|
| 2314 | (let ((slot-name (slot-definition-name slot))) |
|---|
| 2315 | (multiple-value-bind (init-key init-value foundp) |
|---|
| 2316 | (get-properties all-keys (slot-definition-initargs slot)) |
|---|
| 2317 | (if foundp |
|---|
| 2318 | (setf (std-slot-value instance slot-name) init-value) |
|---|
| 2319 | (unless (std-slot-boundp instance slot-name) |
|---|
| 2320 | (let ((initfunction (slot-definition-initfunction slot))) |
|---|
| 2321 | (when (and initfunction (or (eq slot-names t) |
|---|
| 2322 | (memq slot-name slot-names))) |
|---|
| 2323 | (setf (std-slot-value instance slot-name) |
|---|
| 2324 | (funcall initfunction))))))))) |
|---|
| 2325 | instance) |
|---|
| 2326 | |
|---|
| 2327 | (defgeneric shared-initialize (instance slot-names &key)) |
|---|
| 2328 | |
|---|
| 2329 | (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) |
|---|
| 2330 | (std-shared-initialize instance slot-names initargs)) |
|---|
| 2331 | |
|---|
| 2332 | (defmethod shared-initialize ((slot slot-definition) slot-names |
|---|
| 2333 | &rest args |
|---|
| 2334 | &key name initargs initform initfunction |
|---|
| 2335 | readers writers allocation |
|---|
| 2336 | &allow-other-keys) |
|---|
| 2337 | ;;Keyword args are duplicated from init-slot-definition only to have |
|---|
| 2338 | ;;them checked. |
|---|
| 2339 | (declare (ignore slot-names)) ;;TODO? |
|---|
| 2340 | (declare (ignore name initargs initform initfunction readers writers allocation)) |
|---|
| 2341 | ;;For built-in slots |
|---|
| 2342 | (apply #'init-slot-definition slot args) |
|---|
| 2343 | ;;For user-defined slots |
|---|
| 2344 | (call-next-method)) |
|---|
| 2345 | |
|---|
| 2346 | ;;; change-class |
|---|
| 2347 | |
|---|
| 2348 | (defgeneric change-class (instance new-class &key)) |
|---|
| 2349 | |
|---|
| 2350 | (defmethod change-class ((old-instance standard-object) (new-class standard-class) |
|---|
| 2351 | &rest initargs) |
|---|
| 2352 | (let ((old-slots (class-slots (class-of old-instance))) |
|---|
| 2353 | (new-slots (class-slots new-class)) |
|---|
| 2354 | (new-instance (allocate-instance new-class))) |
|---|
| 2355 | ;; "The values of local slots specified by both the class CTO and the class |
|---|
| 2356 | ;; CFROM are retained. If such a local slot was unbound, it remains |
|---|
| 2357 | ;; unbound." |
|---|
| 2358 | (dolist (new-slot new-slots) |
|---|
| 2359 | (when (instance-slot-p new-slot) |
|---|
| 2360 | (let* ((slot-name (slot-definition-name new-slot)) |
|---|
| 2361 | (old-slot (find slot-name old-slots :key 'slot-definition-name))) |
|---|
| 2362 | ;; "The values of slots specified as shared in the class CFROM and as |
|---|
| 2363 | ;; local in the class CTO are retained." |
|---|
| 2364 | (when (and old-slot (slot-boundp old-instance slot-name)) |
|---|
| 2365 | (setf (slot-value new-instance slot-name) |
|---|
| 2366 | (slot-value old-instance slot-name)))))) |
|---|
| 2367 | (swap-slots old-instance new-instance) |
|---|
| 2368 | (rotatef (std-instance-layout new-instance) |
|---|
| 2369 | (std-instance-layout old-instance)) |
|---|
| 2370 | (apply #'update-instance-for-different-class |
|---|
| 2371 | new-instance old-instance initargs) |
|---|
| 2372 | old-instance)) |
|---|
| 2373 | |
|---|
| 2374 | (defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs) |
|---|
| 2375 | (apply #'change-class instance (find-class new-class) initargs)) |
|---|
| 2376 | |
|---|
| 2377 | (defgeneric update-instance-for-different-class (old new &key)) |
|---|
| 2378 | |
|---|
| 2379 | (defmethod update-instance-for-different-class |
|---|
| 2380 | ((old standard-object) (new standard-object) &rest initargs) |
|---|
| 2381 | (let ((added-slots |
|---|
| 2382 | (remove-if #'(lambda (slot-name) |
|---|
| 2383 | (slot-exists-p old slot-name)) |
|---|
| 2384 | (mapcar 'slot-definition-name |
|---|
| 2385 | (class-slots (class-of new)))))) |
|---|
| 2386 | (check-initargs new added-slots initargs) |
|---|
| 2387 | (apply #'shared-initialize new added-slots initargs))) |
|---|
| 2388 | |
|---|
| 2389 | ;;; make-instances-obsolete |
|---|
| 2390 | |
|---|
| 2391 | (defgeneric make-instances-obsolete (class)) |
|---|
| 2392 | |
|---|
| 2393 | (defmethod make-instances-obsolete ((class standard-class)) |
|---|
| 2394 | (%make-instances-obsolete class)) |
|---|
| 2395 | |
|---|
| 2396 | (defmethod make-instances-obsolete ((class symbol)) |
|---|
| 2397 | (make-instances-obsolete (find-class class)) |
|---|
| 2398 | class) |
|---|
| 2399 | |
|---|
| 2400 | ;;; update-instance-for-redefined-class |
|---|
| 2401 | |
|---|
| 2402 | (defgeneric update-instance-for-redefined-class (instance |
|---|
| 2403 | added-slots |
|---|
| 2404 | discarded-slots |
|---|
| 2405 | property-list |
|---|
| 2406 | &rest initargs |
|---|
| 2407 | &key |
|---|
| 2408 | &allow-other-keys)) |
|---|
| 2409 | |
|---|
| 2410 | (defmethod update-instance-for-redefined-class ((instance standard-object) |
|---|
| 2411 | added-slots |
|---|
| 2412 | discarded-slots |
|---|
| 2413 | property-list |
|---|
| 2414 | &rest initargs) |
|---|
| 2415 | (check-initargs instance added-slots initargs) |
|---|
| 2416 | (apply #'shared-initialize instance added-slots initargs)) |
|---|
| 2417 | |
|---|
| 2418 | ;;; Methods having to do with class metaobjects. |
|---|
| 2419 | |
|---|
| 2420 | (defmethod initialize-instance :after ((class standard-class) &rest args) |
|---|
| 2421 | (apply #'std-after-initialization-for-classes class args)) |
|---|
| 2422 | |
|---|
| 2423 | ;;; Finalize inheritance |
|---|
| 2424 | |
|---|
| 2425 | (defgeneric finalize-inheritance (class)) |
|---|
| 2426 | |
|---|
| 2427 | (defmethod finalize-inheritance ((class standard-class)) |
|---|
| 2428 | (std-finalize-inheritance class)) |
|---|
| 2429 | |
|---|
| 2430 | ;;; Class precedence lists |
|---|
| 2431 | |
|---|
| 2432 | (defgeneric compute-class-precedence-list (class)) |
|---|
| 2433 | (defmethod compute-class-precedence-list ((class standard-class)) |
|---|
| 2434 | (std-compute-class-precedence-list class)) |
|---|
| 2435 | |
|---|
| 2436 | ;;; Slot inheritance |
|---|
| 2437 | |
|---|
| 2438 | (defgeneric compute-slots (class)) |
|---|
| 2439 | (defmethod compute-slots ((class standard-class)) |
|---|
| 2440 | (std-compute-slots class)) |
|---|
| 2441 | |
|---|
| 2442 | (defgeneric compute-effective-slot-definition (class direct-slots)) |
|---|
| 2443 | (defmethod compute-effective-slot-definition |
|---|
| 2444 | ((class standard-class) direct-slots) |
|---|
| 2445 | (std-compute-effective-slot-definition class direct-slots)) |
|---|
| 2446 | |
|---|
| 2447 | ;;; Methods having to do with generic function metaobjects. |
|---|
| 2448 | |
|---|
| 2449 | (defmethod initialize-instance :after ((gf standard-generic-function) &key) |
|---|
| 2450 | (finalize-generic-function gf)) |
|---|
| 2451 | |
|---|
| 2452 | ;;; Methods having to do with generic function invocation. |
|---|
| 2453 | |
|---|
| 2454 | (defgeneric compute-discriminating-function (gf)) |
|---|
| 2455 | (defmethod compute-discriminating-function ((gf standard-generic-function)) |
|---|
| 2456 | (std-compute-discriminating-function gf)) |
|---|
| 2457 | |
|---|
| 2458 | (defgeneric method-more-specific-p (gf method1 method2 required-classes)) |
|---|
| 2459 | |
|---|
| 2460 | (defmethod method-more-specific-p ((gf standard-generic-function) |
|---|
| 2461 | method1 method2 required-classes) |
|---|
| 2462 | (std-method-more-specific-p method1 method2 required-classes |
|---|
| 2463 | (generic-function-argument-precedence-order gf))) |
|---|
| 2464 | |
|---|
| 2465 | (defgeneric compute-effective-method-function (gf methods)) |
|---|
| 2466 | (defmethod compute-effective-method-function ((gf standard-generic-function) methods) |
|---|
| 2467 | (std-compute-effective-method-function gf methods)) |
|---|
| 2468 | |
|---|
| 2469 | (defgeneric compute-applicable-methods (gf args)) |
|---|
| 2470 | (defmethod compute-applicable-methods ((gf standard-generic-function) args) |
|---|
| 2471 | (%compute-applicable-methods gf args)) |
|---|
| 2472 | |
|---|
| 2473 | ;;; Slot definition accessors |
|---|
| 2474 | |
|---|
| 2475 | (map nil (lambda (sym) |
|---|
| 2476 | (fmakunbound sym) ;;we need to redefine them as GFs |
|---|
| 2477 | (fmakunbound `(setf ,sym)) |
|---|
| 2478 | (export sym)) |
|---|
| 2479 | '(slot-definition-allocation |
|---|
| 2480 | slot-definition-initargs |
|---|
| 2481 | slot-definition-initform |
|---|
| 2482 | slot-definition-initfunction |
|---|
| 2483 | slot-definition-name |
|---|
| 2484 | slot-definition-readers |
|---|
| 2485 | slot-definition-writers |
|---|
| 2486 | slot-definition-allocation-class)) |
|---|
| 2487 | |
|---|
| 2488 | (defmacro slot-definition-dispatch (slot-definition std-form generic-form) |
|---|
| 2489 | `(let (($cl (class-of ,slot-definition))) |
|---|
| 2490 | (case $cl |
|---|
| 2491 | ((+the-slot-definition-class+ |
|---|
| 2492 | +the-direct-slot-definition-class+ |
|---|
| 2493 | +the-effective-slot-definition-class+) |
|---|
| 2494 | ,std-form) |
|---|
| 2495 | (t ,generic-form)))) |
|---|
| 2496 | |
|---|
| 2497 | (defgeneric slot-definition-allocation (slot-definition) |
|---|
| 2498 | (:method ((slot-definition slot-definition)) |
|---|
| 2499 | (slot-definition-dispatch slot-definition |
|---|
| 2500 | (%slot-definition-allocation slot-definition) |
|---|
| 2501 | (slot-value slot-definition 'sys::allocation)))) |
|---|
| 2502 | |
|---|
| 2503 | (defgeneric (setf slot-definition-allocation) (value slot-definition) |
|---|
| 2504 | (:method (value (slot-definition slot-definition)) |
|---|
| 2505 | (slot-definition-dispatch slot-definition |
|---|
| 2506 | (set-slot-definition-allocation slot-definition value) |
|---|
| 2507 | (setf (slot-value slot-definition 'sys::allocation) value)))) |
|---|
| 2508 | |
|---|
| 2509 | (defgeneric slot-definition-initargs (slot-definition) |
|---|
| 2510 | (:method ((slot-definition slot-definition)) |
|---|
| 2511 | (slot-definition-dispatch slot-definition |
|---|
| 2512 | (%slot-definition-initargs slot-definition) |
|---|
| 2513 | (slot-value slot-definition 'sys::initargs)))) |
|---|
| 2514 | |
|---|
| 2515 | (defgeneric (setf slot-definition-initargs) (value slot-definition) |
|---|
| 2516 | (:method (value (slot-definition slot-definition)) |
|---|
| 2517 | (slot-definition-dispatch slot-definition |
|---|
| 2518 | (set-slot-definition-initargs slot-definition value) |
|---|
| 2519 | (setf (slot-value slot-definition 'sys::initargs) value)))) |
|---|
| 2520 | |
|---|
| 2521 | (defgeneric slot-definition-initform (slot-definition) |
|---|
| 2522 | (:method ((slot-definition slot-definition)) |
|---|
| 2523 | (slot-definition-dispatch slot-definition |
|---|
| 2524 | (%slot-definition-initform slot-definition) |
|---|
| 2525 | (slot-value slot-definition 'sys::initform)))) |
|---|
| 2526 | |
|---|
| 2527 | (defgeneric (setf slot-definition-initform) (value slot-definition) |
|---|
| 2528 | (:method (value (slot-definition slot-definition)) |
|---|
| 2529 | (slot-definition-dispatch slot-definition |
|---|
| 2530 | (set-slot-definition-initform slot-definition value) |
|---|
| 2531 | (setf (slot-value slot-definition 'sys::initform) value)))) |
|---|
| 2532 | |
|---|
| 2533 | (defgeneric slot-definition-initfunction (slot-definition) |
|---|
| 2534 | (:method ((slot-definition slot-definition)) |
|---|
| 2535 | (slot-definition-dispatch slot-definition |
|---|
| 2536 | (%slot-definition-initfunction slot-definition) |
|---|
| 2537 | (slot-value slot-definition 'sys::initfunction)))) |
|---|
| 2538 | |
|---|
| 2539 | (defgeneric (setf slot-definition-initfunction) (value slot-definition) |
|---|
| 2540 | (:method (value (slot-definition slot-definition)) |
|---|
| 2541 | (slot-definition-dispatch slot-definition |
|---|
| 2542 | (set-slot-definition-initfunction slot-definition value) |
|---|
| 2543 | (setf (slot-value slot-definition 'sys::initfunction) value)))) |
|---|
| 2544 | |
|---|
| 2545 | (defgeneric slot-definition-name (slot-definition) |
|---|
| 2546 | (:method ((slot-definition slot-definition)) |
|---|
| 2547 | (slot-definition-dispatch slot-definition |
|---|
| 2548 | (%slot-definition-name slot-definition) |
|---|
| 2549 | (slot-value slot-definition 'sys::name)))) |
|---|
| 2550 | |
|---|
| 2551 | (defgeneric (setf slot-definition-name) (value slot-definition) |
|---|
| 2552 | (:method (value (slot-definition slot-definition)) |
|---|
| 2553 | (slot-definition-dispatch slot-definition |
|---|
| 2554 | (set-slot-definition-name slot-definition value) |
|---|
| 2555 | (setf (slot-value slot-definition 'sys::name) value)))) |
|---|
| 2556 | |
|---|
| 2557 | (defgeneric slot-definition-readers (slot-definition) |
|---|
| 2558 | (:method ((slot-definition slot-definition)) |
|---|
| 2559 | (slot-definition-dispatch slot-definition |
|---|
| 2560 | (%slot-definition-readers slot-definition) |
|---|
| 2561 | (slot-value slot-definition 'sys::readers)))) |
|---|
| 2562 | |
|---|
| 2563 | (defgeneric (setf slot-definition-readers) (value slot-definition) |
|---|
| 2564 | (:method (value (slot-definition slot-definition)) |
|---|
| 2565 | (slot-definition-dispatch slot-definition |
|---|
| 2566 | (set-slot-definition-readers slot-definition value) |
|---|
| 2567 | (setf (slot-value slot-definition 'sys::readers) value)))) |
|---|
| 2568 | |
|---|
| 2569 | (defgeneric slot-definition-writers (slot-definition) |
|---|
| 2570 | (:method ((slot-definition slot-definition)) |
|---|
| 2571 | (slot-definition-dispatch slot-definition |
|---|
| 2572 | (%slot-definition-writers slot-definition) |
|---|
| 2573 | (slot-value slot-definition 'sys::writers)))) |
|---|
| 2574 | |
|---|
| 2575 | (defgeneric (setf slot-definition-writers) (value slot-definition) |
|---|
| 2576 | (:method (value (slot-definition slot-definition)) |
|---|
| 2577 | (slot-definition-dispatch slot-definition |
|---|
| 2578 | (set-slot-definition-writers slot-definition value) |
|---|
| 2579 | (setf (slot-value slot-definition 'sys::writers) value)))) |
|---|
| 2580 | |
|---|
| 2581 | (defgeneric slot-definition-allocation-class (slot-definition) |
|---|
| 2582 | (:method ((slot-definition slot-definition)) |
|---|
| 2583 | (slot-definition-dispatch slot-definition |
|---|
| 2584 | (%slot-definition-allocation-class slot-definition) |
|---|
| 2585 | (slot-value slot-definition 'sys::allocation-class)))) |
|---|
| 2586 | |
|---|
| 2587 | (defgeneric (setf slot-definition-allocation-class) (value slot-definition) |
|---|
| 2588 | (:method (value (slot-definition slot-definition)) |
|---|
| 2589 | (slot-definition-dispatch slot-definition |
|---|
| 2590 | (set-slot-definition-allocation-class slot-definition value) |
|---|
| 2591 | (setf (slot-value slot-definition 'sys::allocation-class) value)))) |
|---|
| 2592 | |
|---|
| 2593 | (defgeneric slot-definition-location (slot-definition) |
|---|
| 2594 | (:method ((slot-definition slot-definition)) |
|---|
| 2595 | (slot-definition-dispatch slot-definition |
|---|
| 2596 | (%slot-definition-location slot-definition) |
|---|
| 2597 | (slot-value slot-definition 'sys::location)))) |
|---|
| 2598 | |
|---|
| 2599 | (defgeneric (setf slot-definition-location) (value slot-definition) |
|---|
| 2600 | (:method (value (slot-definition slot-definition)) |
|---|
| 2601 | (slot-definition-dispatch slot-definition |
|---|
| 2602 | (set-slot-definition-location slot-definition value) |
|---|
| 2603 | (setf (slot-value slot-definition 'sys::location) value)))) |
|---|
| 2604 | |
|---|
| 2605 | ;;; No %slot-definition-type. |
|---|
| 2606 | |
|---|
| 2607 | |
|---|
| 2608 | ;;; Conditions. |
|---|
| 2609 | |
|---|
| 2610 | (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) |
|---|
| 2611 | (let ((parent-types (or parent-types '(condition))) |
|---|
| 2612 | (report nil)) |
|---|
| 2613 | (dolist (option options) |
|---|
| 2614 | (when (eq (car option) :report) |
|---|
| 2615 | (setf report (cadr option)) |
|---|
| 2616 | (setf options (delete option options :test #'equal)) |
|---|
| 2617 | (return))) |
|---|
| 2618 | (typecase report |
|---|
| 2619 | (null |
|---|
| 2620 | `(progn |
|---|
| 2621 | (defclass ,name ,parent-types ,slot-specs ,@options) |
|---|
| 2622 | ',name)) |
|---|
| 2623 | (string |
|---|
| 2624 | `(progn |
|---|
| 2625 | (defclass ,name ,parent-types ,slot-specs ,@options) |
|---|
| 2626 | (defmethod print-object ((condition ,name) stream) |
|---|
| 2627 | (if *print-escape* |
|---|
| 2628 | (call-next-method) |
|---|
| 2629 | (progn (write-string ,report stream) condition))) |
|---|
| 2630 | ',name)) |
|---|
| 2631 | (t |
|---|
| 2632 | `(progn |
|---|
| 2633 | (defclass ,name ,parent-types ,slot-specs ,@options) |
|---|
| 2634 | (defmethod print-object ((condition ,name) stream) |
|---|
| 2635 | (if *print-escape* |
|---|
| 2636 | (call-next-method) |
|---|
| 2637 | (funcall #',report condition stream))) |
|---|
| 2638 | ',name))))) |
|---|
| 2639 | |
|---|
| 2640 | (defun make-condition (type &rest initargs) |
|---|
| 2641 | (or (%make-condition type initargs) |
|---|
| 2642 | (let ((class (if (symbolp type) (find-class type) type))) |
|---|
| 2643 | (apply #'make-instance class initargs)))) |
|---|
| 2644 | |
|---|
| 2645 | ;; Adapted from SBCL. |
|---|
| 2646 | ;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION. |
|---|
| 2647 | (defun coerce-to-condition (datum arguments default-type fun-name) |
|---|
| 2648 | (cond ((typep datum 'condition) |
|---|
| 2649 | (when arguments |
|---|
| 2650 | (error 'simple-type-error |
|---|
| 2651 | :datum arguments |
|---|
| 2652 | :expected-type 'null |
|---|
| 2653 | :format-control "You may not supply additional arguments when giving ~S to ~S." |
|---|
| 2654 | :format-arguments (list datum fun-name))) |
|---|
| 2655 | datum) |
|---|
| 2656 | ((symbolp datum) |
|---|
| 2657 | (apply #'make-condition datum arguments)) |
|---|
| 2658 | ((or (stringp datum) (functionp datum)) |
|---|
| 2659 | (make-condition default-type |
|---|
| 2660 | :format-control datum |
|---|
| 2661 | :format-arguments arguments)) |
|---|
| 2662 | (t |
|---|
| 2663 | (error 'simple-type-error |
|---|
| 2664 | :datum datum |
|---|
| 2665 | :expected-type '(or symbol string) |
|---|
| 2666 | :format-control "Bad argument to ~S: ~S." |
|---|
| 2667 | :format-arguments (list fun-name datum))))) |
|---|
| 2668 | |
|---|
| 2669 | (defgeneric make-load-form (object &optional environment)) |
|---|
| 2670 | |
|---|
| 2671 | (defmethod make-load-form ((object t) &optional environment) |
|---|
| 2672 | (declare (ignore environment)) |
|---|
| 2673 | (apply #'no-applicable-method #'make-load-form (list object))) |
|---|
| 2674 | |
|---|
| 2675 | (defmethod make-load-form ((class class) &optional environment) |
|---|
| 2676 | (declare (ignore environment)) |
|---|
| 2677 | (let ((name (class-name class))) |
|---|
| 2678 | (unless (and name (eq (find-class name nil) class)) |
|---|
| 2679 | (error 'simple-type-error |
|---|
| 2680 | :format-control "Can't use anonymous or undefined class as a constant: ~S." |
|---|
| 2681 | :format-arguments (list class))) |
|---|
| 2682 | `(find-class ',name))) |
|---|
| 2683 | |
|---|
| 2684 | (defun invalid-method-error (method format-control &rest args) |
|---|
| 2685 | (let ((message (apply #'format nil format-control args))) |
|---|
| 2686 | (error "Invalid method error for ~S:~% ~A" method message))) |
|---|
| 2687 | |
|---|
| 2688 | (defun method-combination-error (format-control &rest args) |
|---|
| 2689 | (let ((message (apply #'format nil format-control args))) |
|---|
| 2690 | (error "Method combination error in CLOS dispatch:~% ~A" message))) |
|---|
| 2691 | |
|---|
| 2692 | (fmakunbound 'no-applicable-method) |
|---|
| 2693 | (defgeneric no-applicable-method (generic-function &rest args)) |
|---|
| 2694 | |
|---|
| 2695 | (defmethod no-applicable-method (generic-function &rest args) |
|---|
| 2696 | (error "There is no applicable method for the generic function ~S when called with arguments ~S." |
|---|
| 2697 | generic-function |
|---|
| 2698 | args)) |
|---|
| 2699 | |
|---|
| 2700 | (defgeneric find-method (generic-function |
|---|
| 2701 | qualifiers |
|---|
| 2702 | specializers |
|---|
| 2703 | &optional errorp)) |
|---|
| 2704 | |
|---|
| 2705 | (defmethod find-method ((generic-function standard-generic-function) |
|---|
| 2706 | qualifiers specializers &optional (errorp t)) |
|---|
| 2707 | (%find-method generic-function qualifiers specializers errorp)) |
|---|
| 2708 | |
|---|
| 2709 | (defgeneric add-method (generic-function method)) |
|---|
| 2710 | |
|---|
| 2711 | (defmethod add-method ((generic-function standard-generic-function) (method method)) |
|---|
| 2712 | (let ((method-lambda-list (method-lambda-list method)) |
|---|
| 2713 | (gf-lambda-list (generic-function-lambda-list generic-function))) |
|---|
| 2714 | (check-method-lambda-list method-lambda-list gf-lambda-list)) |
|---|
| 2715 | (%add-method generic-function method)) |
|---|
| 2716 | |
|---|
| 2717 | (defgeneric remove-method (generic-function method)) |
|---|
| 2718 | |
|---|
| 2719 | (defmethod remove-method ((generic-function standard-generic-function) method) |
|---|
| 2720 | (%remove-method generic-function method)) |
|---|
| 2721 | |
|---|
| 2722 | ;; See describe.lisp. |
|---|
| 2723 | (defgeneric describe-object (object stream)) |
|---|
| 2724 | |
|---|
| 2725 | ;; FIXME |
|---|
| 2726 | (defgeneric no-next-method (generic-function method &rest args)) |
|---|
| 2727 | |
|---|
| 2728 | ;; FIXME |
|---|
| 2729 | (defgeneric function-keywords (method)) |
|---|
| 2730 | |
|---|
| 2731 | (setf *clos-booting* nil) |
|---|
| 2732 | |
|---|
| 2733 | (defgeneric class-prototype (class)) |
|---|
| 2734 | |
|---|
| 2735 | (defmethod class-prototype :before (class) |
|---|
| 2736 | (unless (class-finalized-p class) |
|---|
| 2737 | (error "~@<~S is not finalized.~:@>" class))) |
|---|
| 2738 | |
|---|
| 2739 | (defmethod class-prototype ((class standard-class)) |
|---|
| 2740 | (allocate-instance class)) |
|---|
| 2741 | |
|---|
| 2742 | (defmethod class-prototype ((class structure-class)) |
|---|
| 2743 | (allocate-instance class)) |
|---|
| 2744 | |
|---|
| 2745 | (provide 'clos) |
|---|
