mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 14:51:20 -08:00
325 lines
12 KiB
Common Lisp
325 lines
12 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
|
||
;;;;
|
||
;;;; Copyright (c) 1992, Giuseppe Attardi.
|
||
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
||
;;;;
|
||
;;;; This program is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Library General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 2 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; See file '../Copyright' for full details.
|
||
|
||
(in-package "CLOS")
|
||
|
||
;;; ----------------------------------------------------------------------
|
||
;;; slots
|
||
|
||
#|
|
||
(defclass effective-slot-definition (slot-definition))
|
||
|
||
(defclass direct-slot-definition (slot-definition))
|
||
|
||
(defclass standard-slot-definition (slot-definition))
|
||
|
||
(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition))
|
||
|
||
(defclass standard-effective-slot-definition (standard-slot-definition direct-slot-definition))
|
||
|#
|
||
|
||
(defmethod reader-method-class ((class std-class)
|
||
(direct-slot direct-slot-definition)
|
||
&rest initargs)
|
||
(declare (ignore class direct-slot initargs))
|
||
(find-class (if (member (class-name (class-of class))
|
||
'(standard-class
|
||
funcallable-standard-class
|
||
structure-class))
|
||
'standard-optimized-reader-method
|
||
'standard-reader-method)))
|
||
|
||
(defmethod writer-method-class ((class std-class)
|
||
(direct-slot direct-slot-definition)
|
||
&rest initargs)
|
||
(declare (ignore class direct-slot initargs))
|
||
(find-class (if (member (class-name (class-of class))
|
||
'(standard-class
|
||
funcallable-standard-class
|
||
structure-class))
|
||
'standard-optimized-writer-method
|
||
'standard-reader-method)))
|
||
|
||
;;; ----------------------------------------------------------------------
|
||
;;; Fixup
|
||
|
||
(defun register-method-with-specializers (method)
|
||
(declare (si::c-local))
|
||
(loop for spec in (method-specializers method)
|
||
do (add-direct-method spec method)))
|
||
|
||
(dolist (method-info *early-methods* (makunbound '*EARLY-METHODS*))
|
||
(let* ((method-name (car method-info))
|
||
(gfun (fdefinition method-name))
|
||
(standard-method-class (find-class 'standard-method)))
|
||
(when (eq 'T (class-id (si:instance-class gfun)))
|
||
;; complete the generic function object
|
||
(si:instance-class-set gfun (find-class 'STANDARD-GENERIC-FUNCTION))
|
||
(si::instance-sig-set gfun)
|
||
(setf (slot-value gfun 'method-class) standard-method-class)
|
||
(setf (slot-value gfun 'docstring) nil)
|
||
)
|
||
(dolist (method (cdr method-info))
|
||
;; complete the method object
|
||
(let ((old-class (si::instance-class method)))
|
||
(si::instance-class-set method
|
||
(cond ((null old-class)
|
||
(find-class 'standard-method))
|
||
((symbolp old-class)
|
||
(find-class (truly-the symbol old-class)))
|
||
(t
|
||
old-class))))
|
||
(si::instance-sig-set gfun)
|
||
(register-method-with-specializers method)
|
||
)
|
||
))
|
||
|
||
|
||
;;; ----------------------------------------------------------------------
|
||
;;; redefined
|
||
|
||
(defun method-p (method) (typep method 'METHOD))
|
||
|
||
(defun make-method (method-class qualifiers specializers arglist function options)
|
||
(apply #'make-instance
|
||
method-class
|
||
:generic-function nil
|
||
:qualifiers qualifiers
|
||
:lambda-list arglist
|
||
:specializers specializers
|
||
:function function
|
||
:allow-other-keys t
|
||
options))
|
||
|
||
(defun all-keywords (l)
|
||
(declare (si::c-local))
|
||
(let ((all-keys '()))
|
||
(do ((l (rest l) (cddddr l)))
|
||
((null l)
|
||
all-keys)
|
||
(push (first l) all-keys))))
|
||
|
||
(defun congruent-lambda-p (l1 l2)
|
||
(multiple-value-bind (r1 opts1 rest1 key-flag1 keywords1 a-o-k1)
|
||
(si::process-lambda-list l1 'FUNCTION)
|
||
(declare (ignore a-o-k1))
|
||
(multiple-value-bind (r2 opts2 rest2 key-flag2 keywords2 a-o-k2)
|
||
(si::process-lambda-list l2 'FUNCTION)
|
||
(and (= (length r2) (length r1))
|
||
(= (length opts1) (length opts2))
|
||
(eq (and (null rest1) (null key-flag1))
|
||
(and (null rest2) (null key-flag2)))
|
||
;; All keywords mentioned in the genericf function
|
||
;; must be accepted by the method.
|
||
(or (null key-flag1)
|
||
(null key-flag2)
|
||
a-o-k2
|
||
(null (set-difference (all-keywords keywords1)
|
||
(all-keywords keywords2))))
|
||
t))))
|
||
|
||
(defun add-method (gf method)
|
||
(declare (notinline method-qualifiers)) ; during boot it's a structure accessor
|
||
;;
|
||
;; 1) The method must not be already installed in another generic function.
|
||
;;
|
||
(let ((other-gf (method-generic-function method)))
|
||
(unless (or (null other-gf) (eq other-gf gf))
|
||
(error "The method ~A belongs to the generic function ~A ~
|
||
and cannot be added to ~A." method other-gf gf)))
|
||
;;
|
||
;; 2) The method and the generic function should have congruent lambda
|
||
;; lists. That is, it should accept the same number of required and
|
||
;; optional arguments, and only accept keyword arguments when the generic
|
||
;; function does.
|
||
;;
|
||
(let ((new-lambda-list (method-lambda-list method)))
|
||
(if (slot-boundp gf 'lambda-list)
|
||
(let ((old-lambda-list (generic-function-lambda-list gf)))
|
||
(unless (congruent-lambda-p old-lambda-list new-lambda-list)
|
||
(error "Cannot add the method ~A to the generic function ~A because ~
|
||
their lambda lists ~A and ~A are not congruent."
|
||
method gf old-lambda-list new-lambda-list)))
|
||
(reinitialize-instance gf :lambda-list new-lambda-list)))
|
||
;;
|
||
;; 3) Finally, it is inserted in the list of methods, and the method is
|
||
;; marked as belonging to a generic function.
|
||
;;
|
||
(when (generic-function-methods gf)
|
||
(let* ((method-qualifiers (method-qualifiers method))
|
||
(specializers (method-specializers method))
|
||
(found (find-method gf method-qualifiers specializers nil)))
|
||
(when found
|
||
(remove-method gf found))))
|
||
;;
|
||
;; We install the method by:
|
||
;; i) Adding it to the list of methods
|
||
(push method (generic-function-methods gf))
|
||
(setf (method-generic-function method) gf)
|
||
;; ii) Updating the specializers list of the generic function. Notice that
|
||
;; we should call add-direct-method for each specializer but specializer
|
||
;; objects are not yet implemented
|
||
#+(or)
|
||
(dolist (spec (method-specializers method))
|
||
(add-direct-method spec method))
|
||
;; iii) Computing a new discriminating function... Well, since the core
|
||
;; ECL does not need the discriminating function because we always use
|
||
;; the same one, we just update the spec-how list of the generic function.
|
||
(compute-g-f-spec-list gf)
|
||
(set-generic-function-dispatch gf)
|
||
;; iv) Update dependents.
|
||
(update-dependents gf (list 'add-method method))
|
||
;; v) Register with specializers
|
||
(register-method-with-specializers method)
|
||
gf)
|
||
|
||
(defun function-to-method (name signature)
|
||
(let* ((aux-name 'temp-method)
|
||
(method (eval `(defmethod ,aux-name ,signature)))
|
||
(generic-function (fdefinition aux-name)))
|
||
(setf (method-function method) (wrapped-method-function (fdefinition name)))
|
||
(setf (fdefinition name) generic-function)
|
||
(setf (generic-function-name generic-function) name)
|
||
(fmakunbound aux-name)))
|
||
|
||
(defun remove-method (gf method)
|
||
(setf (generic-function-methods gf)
|
||
(delete method (generic-function-methods gf))
|
||
(method-generic-function method) nil)
|
||
(si:clear-gfun-hash gf)
|
||
(loop for spec in (method-specializers method)
|
||
do (remove-direct-method spec method))
|
||
(compute-g-f-spec-list gf)
|
||
(set-generic-function-dispatch gf)
|
||
(update-dependents gf (list 'remove-method method))
|
||
gf)
|
||
|
||
(function-to-method 'add-method '((gf standard-generic-function)
|
||
(method standard-method)))
|
||
(function-to-method 'remove-method '((gf standard-generic-function)
|
||
(method standard-method)))
|
||
(function-to-method 'find-method '((gf standard-generic-function)
|
||
qualifiers specializers &optional error))
|
||
|
||
;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places,
|
||
;;; including instance initialization. This means we cannot just redefine it.
|
||
;;; Instead, we create an auxiliary function and move definitions from one to
|
||
;;; the other.
|
||
#+(or)
|
||
(defgeneric aux-compute-applicable-methods (gf args)
|
||
(:method ((gf standard-generic-function) args)
|
||
(std-compute-applicable-methods gf args)))
|
||
|
||
(defmethod aux-compute-applicable-methods ((gf standard-generic-function) args)
|
||
(std-compute-applicable-methods gf args))
|
||
(let ((aux #'aux-compute-applicable-methods))
|
||
(setf (generic-function-name aux) 'compute-applicable-methods
|
||
(fdefinition 'compute-applicable-methods) aux))
|
||
|
||
(defmethod compute-applicable-methods-using-classes
|
||
((gf standard-generic-function) classes)
|
||
(std-compute-applicable-methods-using-classes gf classes))
|
||
|
||
(function-to-method 'compute-effective-method
|
||
'((gf standard-generic-function) method-combination applicable-methods))
|
||
|
||
;;; ----------------------------------------------------------------------
|
||
;;; Error messages
|
||
|
||
(defmethod no-applicable-method (gf args)
|
||
(error "No applicable method for ~S with arguments of types~{~& ~A~}"
|
||
(generic-function-name gf)
|
||
(mapcar #'type-of args)))
|
||
|
||
(defmethod no-next-method (gf method &rest args)
|
||
(declare (ignore gf))
|
||
(error "In method ~A~%No next method given arguments ~A" method args))
|
||
|
||
(defun no-primary-method (gf &rest args)
|
||
(error "Generic function: ~A. No primary method given arguments: ~S"
|
||
(generic-function-name gf) args))
|
||
|
||
;;; Now we protect classes from redefinition:
|
||
(eval-when (compile load)
|
||
(defun setf-find-class (new-value name &optional errorp env)
|
||
(declare (ignore errorp))
|
||
(let ((old-class (find-class name nil env)))
|
||
(cond
|
||
((typep old-class 'built-in-class)
|
||
(error "The class associated to the CL specifier ~S cannot be changed."
|
||
name))
|
||
((member name '(CLASS BUILT-IN-CLASS) :test #'eq)
|
||
(error "The kernel CLOS class ~S cannot be changed." name))
|
||
((classp new-value)
|
||
(setf (gethash name si:*class-name-hash-table*) new-value))
|
||
((null new-value) (remhash name si:*class-name-hash-table*))
|
||
(t (error "~A is not a class." new-value))))
|
||
new-value)
|
||
)
|
||
|
||
;;; ----------------------------------------------------------------------
|
||
;;; DEPENDENT MAINTENANCE PROTOCOL
|
||
;;;
|
||
|
||
(defmethod add-dependent ((c class) dep)
|
||
(pushnew dep (class-dependents c)))
|
||
|
||
(defmethod add-dependent ((c generic-function) dependent)
|
||
(pushnew dependent (generic-function-dependents c)))
|
||
|
||
(defmethod remove-dependent ((c class) dep)
|
||
(setf (class-dependents c)
|
||
(remove dep (class-dependents c))))
|
||
|
||
(defmethod remove-dependent ((c standard-generic-function) dep)
|
||
(setf (generic-function-dependents c)
|
||
(remove dep (generic-function-dependents c))))
|
||
|
||
(defmethod map-dependents ((c class) function)
|
||
(dolist (d (class-dependents c))
|
||
(funcall function d)))
|
||
|
||
(defmethod map-dependents ((c standard-generic-function) function)
|
||
(dolist (d (generic-function-dependents c))
|
||
(funcall function d)))
|
||
|
||
(defgeneric update-dependent (object dependent &rest initargs))
|
||
|
||
;; After this, update-dependents will work
|
||
(setf *clos-booted* 'map-dependents)
|
||
|
||
(defclass initargs-updater ()
|
||
())
|
||
|
||
(defun recursively-update-classes (a-class)
|
||
(slot-makunbound a-class 'valid-initargs)
|
||
(mapc #'recursively-update-classes (class-direct-subclasses a-class)))
|
||
|
||
(defmethod update-dependent ((object generic-function) (dep initargs-updater)
|
||
&rest initargs)
|
||
(declare (ignore dep initargs object))
|
||
(recursively-update-classes +the-class+))
|
||
|
||
(let ((x (make-instance 'initargs-updater)))
|
||
(add-dependent #'shared-initialize x)
|
||
(add-dependent #'initialize-instance x)
|
||
(add-dependent #'allocate-instance x))
|
||
|
||
(function-to-method 'make-method-lambda
|
||
'((gf standard-generic-function) (method standard-method) lambda-form environment))
|
||
(function-to-method 'compute-discriminating-function
|
||
'((gf standard-generic-function)))
|
||
(function-to-method 'generic-function-method-class
|
||
'((gf standard-generic-function)))
|
||
|
||
(function-to-method 'find-method-combination
|
||
'((gf standard-generic-function) method-combination-type-name method-combination-options))
|