mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 23:02:31 -08:00
397 lines
18 KiB
Common Lisp
397 lines
18 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")
|
|
|
|
(defparameter *clos-booted* nil)
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;;
|
|
;;; FIND-CLASS naming classes.
|
|
;;;
|
|
;;;
|
|
;;; (FIND-CLASS <name>) returns the class named <name>. setf can be used
|
|
;;; with find-class to set the class named <name>. These are "extrinsic"
|
|
;;; names. Neither find-class nor setf of find-class do anything with the
|
|
;;; name slot of the class, they only lookup and change the association from
|
|
;;; name to class.
|
|
;;;
|
|
;;; This is only used during boot. The real one is in built-in.
|
|
(eval-when (compile)
|
|
(defun setf-find-class (new-value class &optional errorp env)
|
|
(warn "Ignoring class definition for ~S" class)))
|
|
|
|
(defun setf-find-class (new-value name &optional errorp env)
|
|
(declare (ignore errorp env))
|
|
(let ((old-class (find-class name nil)))
|
|
(cond
|
|
((and old-class
|
|
(or (typep old-class 'built-in-class)
|
|
(member name '(class built-in-class) :test #'eq)))
|
|
(unless (eq new-value old-class)
|
|
(error "The class associated to the CL specifier ~S cannot be changed."
|
|
name)))
|
|
((classp new-value)
|
|
(setf (gethash name si:*class-name-hash-table*) new-value))
|
|
((null new-value) (remhash name si:*class-name-hash-table*))
|
|
(t (error "~A is not a class." new-value))))
|
|
new-value)
|
|
|
|
(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x))
|
|
|
|
(defun classp (obj)
|
|
(and (si:instancep obj)
|
|
(let ((topmost (find-class 'CLASS nil)))
|
|
;; All instances can be classes until the class CLASS has
|
|
;; been installed. Otherwise, we check the parents.
|
|
;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost))))
|
|
(or (null topmost)
|
|
(si::subclassp (si::instance-class obj) topmost)))
|
|
t))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;; Methods
|
|
|
|
(defun install-method (name qualifiers specializers lambda-list fun wrap &rest options)
|
|
(declare (notinline ensure-generic-function))
|
|
; (record-definition 'method `(method ,name ,@qualifiers ,specializers))
|
|
(let* ((gf (ensure-generic-function name))
|
|
(fun (if wrap (wrapped-method-function fun) fun))
|
|
(specializers (mapcar #'(lambda (x)
|
|
(cond ((consp x) (intern-eql-specializer (second x)))
|
|
((typep x 'specializer) x)
|
|
((find-class x nil))
|
|
(t
|
|
(error "In method definition for ~A, found an invalid specializer ~A" name specializers))))
|
|
specializers))
|
|
(method (make-method (generic-function-method-class gf)
|
|
qualifiers specializers lambda-list
|
|
fun options)))
|
|
(add-method gf method)
|
|
method))
|
|
|
|
(defun wrapped-method-function (method-function)
|
|
#'(lambda (.combined-method-args. *next-methods*)
|
|
(declare (special .combined-method-args. *next-methods*))
|
|
(apply method-function .combined-method-args.)))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;; early versions
|
|
|
|
;;; early version used during bootstrap
|
|
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
|
|
(if (and (fboundp name) (si::instancep (fdefinition name)))
|
|
(fdefinition name)
|
|
;; create a fake standard-generic-function object:
|
|
(with-early-make-instance +standard-generic-function-slots+
|
|
(gfun (find-class 'standard-generic-function)
|
|
:name name
|
|
:spec-list nil
|
|
:method-combination (find-method-combination nil 'standard nil)
|
|
:lambda-list lambda-list
|
|
:argument-precedence-order
|
|
(and l-l-p (rest (si::process-lambda-list lambda-list t)))
|
|
:method-class (find-class 'standard-method)
|
|
:docstring nil
|
|
:methods nil
|
|
:a-p-o-function nil
|
|
:declarations nil
|
|
:dependents nil)
|
|
;; create a new gfun
|
|
(set-funcallable-instance-function gfun 'standard-generic-function)
|
|
(setf (fdefinition name) gfun)
|
|
gfun)))
|
|
|
|
(defun (setf generic-function-name) (new-name gf)
|
|
(if *clos-booted*
|
|
(reinitialize-instance gf :name new-name)
|
|
(setf (slot-value gf 'name) new-name)))
|
|
|
|
(defun default-dispatch (generic-function)
|
|
(cond ((null *clos-booted*)
|
|
'standard-generic-function)
|
|
((eq (class-id (class-of generic-function))
|
|
'standard-generic-function)
|
|
'standard-generic-function)
|
|
(t)))
|
|
|
|
(defun compute-discriminating-function (generic-function)
|
|
(values #'(lambda (&rest args)
|
|
(multiple-value-bind (method-list ok)
|
|
(compute-applicable-methods-using-classes
|
|
generic-function
|
|
(mapcar #'class-of args))
|
|
(unless ok
|
|
(setf method-list
|
|
(compute-applicable-methods generic-function args))
|
|
(unless method-list
|
|
(apply #'no-applicable-method generic-function args)))
|
|
(funcall (compute-effective-method-function
|
|
generic-function
|
|
(generic-function-method-combination generic-function)
|
|
method-list)
|
|
args
|
|
nil)))
|
|
t))
|
|
|
|
(defun set-generic-function-dispatch (gfun)
|
|
;;
|
|
;; We have to decide which discriminating function to install:
|
|
;; 1* One supplied by the user
|
|
;; 2* One coded in C that follows the MOP
|
|
;; 3* One in C specialized for slot accessors
|
|
;; 4* One in C that does not use generic versions of compute-applicable-...
|
|
;; Respectively
|
|
;; 1* The user supplies a discriminating function, or the number of arguments
|
|
;; is so large that they cannot be handled by the C dispatchers with
|
|
;; with memoization.
|
|
;; 2* The generic function is not a s-g-f but takes less than 64 arguments
|
|
;; 3* The generic function is a standard-generic-function and all its slots
|
|
;; are standard-{reader,writer}-slots
|
|
;; 4* The generic function is a standard-generic-function with less
|
|
;; than 64 arguments
|
|
;;
|
|
;; This chain of reasoning uses the fact that the user cannot override methods
|
|
;; such as COMPUTE-APPLICABLE-METHODS, or COMPUTE-EFFECTIVE-METHOD, or
|
|
;; COMPUTE-DISCRIMINATING-FUNCTION acting on STANDARD-GENERIC-FUNCTION.
|
|
;;
|
|
(declare (notinline compute-discriminating-function))
|
|
(multiple-value-bind (default-function optimizable)
|
|
;;
|
|
;; If the class is not a standard-generic-function, we must honor whatever function
|
|
;; the user provides. However, we still recognize the case without user-computed
|
|
;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with
|
|
;; a similar implementation in C
|
|
(compute-discriminating-function gfun)
|
|
(let ((methods (slot-value gfun 'methods)))
|
|
(set-funcallable-instance-function
|
|
gfun
|
|
(cond
|
|
;; Case 1*
|
|
((or (not optimizable)
|
|
(> (length (slot-value gfun 'spec-list))
|
|
si::c-arguments-limit))
|
|
default-function)
|
|
;; Case 2*
|
|
((and (not (eq (slot-value (class-of gfun) 'name)
|
|
'standard-generic-function))
|
|
*clos-booted*)
|
|
t)
|
|
((null methods)
|
|
'standard-generic-function)
|
|
;; Cases 3*
|
|
((loop with class = (find-class 'standard-optimized-reader-method nil)
|
|
for m in methods
|
|
always (eq class (class-of m)))
|
|
'standard-optimized-reader-method)
|
|
((loop with class = (find-class 'standard-optimized-writer-method nil)
|
|
for m in methods
|
|
always (eq class (class-of m)))
|
|
'standard-optimized-writer-method)
|
|
;; Case 4*
|
|
(t
|
|
'standard-generic-function))))))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;; COMPUTE-APPLICABLE-METHODS
|
|
;;;
|
|
;;; This part is a source of problems because we have to access slots of
|
|
;;; various objects, which could potentially lead to infinite recursion as
|
|
;;; those accessors require also some dispatch. The solution is to avoid
|
|
;;; calling then generic function that implement the accessors.
|
|
;;; This is possible because:
|
|
;;; 1. The user can only extend compute-applicable-methods if it
|
|
;;; defines a method with a subclass of standard-generic-function
|
|
;;; 2. The user cannot extend slot-value and friends on standard-classes
|
|
;;; due to the restriction "Any method defined by a portable program
|
|
;;; on a specified generic function must have at least one specializer
|
|
;;; that is neither a specified class nor an eql specializer whose
|
|
;;; associated value is an instance of a specified class."
|
|
;;; 3. Subclasses of specified classes preserve the slot order in ECL.
|
|
;;;
|
|
(defun std-compute-applicable-methods (gf args)
|
|
(sort-applicable-methods gf (applicable-method-list gf args) args))
|
|
|
|
(setf (fdefinition 'compute-applicable-methods) #'std-compute-applicable-methods)
|
|
|
|
(defun applicable-method-list (gf args)
|
|
(declare (optimize (speed 3))
|
|
(si::c-local))
|
|
(with-early-accessors (+standard-method-slots+
|
|
+standard-generic-function-slots+
|
|
+eql-specializer-slots+
|
|
+standard-class-slots+)
|
|
(flet ((applicable-method-p (method args)
|
|
(loop for spec in (method-specializers method)
|
|
for arg in args
|
|
always (if (eql-specializer-flag spec)
|
|
(eql arg (eql-specializer-object spec))
|
|
(si::of-class-p arg spec)))))
|
|
(loop for method in (generic-function-methods gf)
|
|
when (applicable-method-p method args)
|
|
collect method))))
|
|
|
|
(defun std-compute-applicable-methods-using-classes (gf classes)
|
|
(declare (optimize (speed 3)))
|
|
(with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+)
|
|
(flet ((applicable-method-p (method classes)
|
|
(loop for spec in (method-specializers method)
|
|
for class in classes
|
|
always (cond ((eql-specializer-flag spec)
|
|
;; EQL specializer invalidate computation
|
|
;; we return NIL
|
|
(when (si::of-class-p (eql-specializer-object spec) class)
|
|
(return-from std-compute-applicable-methods-using-classes
|
|
(values nil nil)))
|
|
nil)
|
|
((si::subclassp class spec))))))
|
|
(values (sort-applicable-methods
|
|
gf
|
|
(loop for method in (generic-function-methods gf)
|
|
when (applicable-method-p method classes)
|
|
collect method)
|
|
classes)
|
|
t))))
|
|
|
|
(defun sort-applicable-methods (gf applicable-list args)
|
|
(declare (optimize (safety 0) (speed 3)))
|
|
(with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
|
|
(let ((f (generic-function-a-p-o-function gf))
|
|
(args-specializers (mapcar #'class-of args)))
|
|
;; reorder args to match the precedence order
|
|
(when f
|
|
(setf args-specializers
|
|
(funcall f (subseq args-specializers 0
|
|
(length (generic-function-argument-precedence-order gf))))))
|
|
;; then order the list
|
|
(do* ((scan applicable-list)
|
|
(most-specific (first scan) (first scan))
|
|
(ordered-list))
|
|
((null (cdr scan))
|
|
(when most-specific
|
|
;; at least one method
|
|
(nreverse
|
|
(push most-specific ordered-list))))
|
|
(dolist (meth (cdr scan))
|
|
(when (eq (compare-methods most-specific
|
|
meth args-specializers f) 2)
|
|
(setq most-specific meth)))
|
|
(setq scan (delete most-specific scan))
|
|
(push most-specific ordered-list)))))
|
|
|
|
(defun compare-methods (method-1 method-2 args-specializers f)
|
|
(declare (si::c-local))
|
|
(with-early-accessors (+standard-method-slots+)
|
|
(let* ((specializers-list-1 (method-specializers method-1))
|
|
(specializers-list-2 (method-specializers method-2)))
|
|
(compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
|
|
(if f (funcall f specializers-list-2) specializers-list-2)
|
|
args-specializers))))
|
|
|
|
(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
|
|
(declare (si::c-local))
|
|
(when (or spec-list-1 spec-list-2)
|
|
(ecase (compare-specializers (first spec-list-1)
|
|
(first spec-list-2)
|
|
(first args-specializers))
|
|
(1 '1)
|
|
(2 '2)
|
|
(=
|
|
(compare-specializers-lists (cdr spec-list-1)
|
|
(cdr spec-list-2)
|
|
(cdr args-specializers)))
|
|
((nil)
|
|
(error "The type specifiers ~S and ~S can not be disambiguated~
|
|
with respect to the argument specializer: ~S"
|
|
(or (car spec-list-1) t)
|
|
(or (car spec-list-2) t)
|
|
(car args-specializers)))))
|
|
)
|
|
|
|
(defun fast-subtypep (spec1 spec2)
|
|
(declare (si::c-local))
|
|
;; Specialized version of subtypep which uses the fact that spec1
|
|
;; and spec2 are either classes or of the form (EQL x)
|
|
(with-early-accessors (+eql-specializer-slots+ +standard-class-slots+)
|
|
(if (eql-specializer-flag spec1)
|
|
(if (eql-specializer-flag spec2)
|
|
(eql (eql-specializer-object spec1)
|
|
(eql-specializer-object spec2))
|
|
(si::of-class-p (eql-specializer-object spec1) spec2))
|
|
(if (eql-specializer-flag spec2)
|
|
;; There is only one class with a single element, which
|
|
;; is NULL = (MEMBER NIL).
|
|
(and (null (eql-specializer-object spec2))
|
|
(eq (class-name spec1) 'null))
|
|
(si::subclassp spec1 spec2)))))
|
|
|
|
(defun compare-specializers (spec-1 spec-2 arg-class)
|
|
(declare (si::c-local))
|
|
(with-early-accessors (+standard-class-slots+ +standard-class-slots+)
|
|
(let* ((cpl (class-precedence-list arg-class)))
|
|
(cond ((eq spec-1 spec-2) '=)
|
|
((fast-subtypep spec-1 spec-2) '1)
|
|
((fast-subtypep spec-2 spec-1) '2)
|
|
((eql-specializer-flag spec-1) '1) ; is this engough?
|
|
((eql-specializer-flag spec-2) '2) ; Beppe
|
|
((member spec-1 (member spec-2 cpl)) '2)
|
|
((member spec-2 (member spec-1 cpl)) '1)
|
|
;; This will force an error in the caller
|
|
(t nil)))))
|
|
|
|
(defun compute-g-f-spec-list (gf)
|
|
(with-early-accessors (+standard-generic-function-slots+
|
|
+eql-specializer-slots+
|
|
+standard-method-slots+)
|
|
(flet ((nupdate-spec-how-list (spec-how-list specializers gf)
|
|
;; update the spec-how of the gfun
|
|
;; computing the or of the previous value and the new one
|
|
(setf spec-how-list (or spec-how-list
|
|
(copy-list specializers)))
|
|
(do* ((l specializers (cdr l))
|
|
(l2 spec-how-list (cdr l2))
|
|
(spec-how)
|
|
(spec-how-old))
|
|
((null l))
|
|
(setq spec-how (first l) spec-how-old (first l2))
|
|
(setf (first l2)
|
|
(if (eql-specializer-flag spec-how)
|
|
(list* (eql-specializer-object spec-how)
|
|
(and (consp spec-how-old) spec-how-old))
|
|
(if (consp spec-how-old)
|
|
spec-how-old
|
|
spec-how))))
|
|
spec-how-list))
|
|
(let* ((spec-how-list nil)
|
|
(function nil)
|
|
(a-p-o (generic-function-argument-precedence-order gf)))
|
|
(dolist (method (generic-function-methods gf))
|
|
(setf spec-how-list
|
|
(nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
|
|
(setf (generic-function-spec-list gf)
|
|
(loop for type in spec-how-list
|
|
for i from 0
|
|
when type collect (cons type i)))
|
|
(let* ((g-f-l-l (generic-function-lambda-list gf)))
|
|
(when (consp g-f-l-l)
|
|
(let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
|
|
(unless (equal a-p-o required-arguments)
|
|
(setf function
|
|
(coerce `(lambda (%list)
|
|
(destructuring-bind ,required-arguments %list
|
|
(list ,@a-p-o)))
|
|
'function))))))
|
|
(setf (generic-function-a-p-o-function gf) function)
|
|
(si:clear-gfun-hash gf)))))
|
|
|
|
(defun print-object (object stream)
|
|
(print-unreadable-object (object stream)))
|