mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-10 23:20:23 -07:00
b1cf56806d
According to the CLHS: > If a DEFCLASS form appears as a top level form, [...] the compiler must make the class definition available to be returned by FIND-CLASS when its environment argument is a value received as the environment parameter of a macro. We already store type definitions in the compiler environment, so we can just reuse that. While The metaobject protocol doesn't specify what happens when compiling DEFCLASS, only what happens when executing it (see https://franz.com/support/documentation/mop/concepts.html#compile-file), real life software breaks when we try to create a full class object at compile time. Therefore, we just create a dummy forward-referenced class object which contains nothing more than a name.
385 lines
18 KiB
Common Lisp
385 lines
18 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
|
|
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
|
|
|
;;;;
|
|
;;;; Copyright (c) 1992, Giuseppe Attardi.
|
|
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
|
;;;;
|
|
;;;; See file 'LICENSE' for the copyright 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-toplevel)
|
|
(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))
|
|
(let ((old-class (find-class name nil env)))
|
|
(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)
|
|
(if env
|
|
(si:proclaim-class name new-value env)
|
|
(setf (gethash name si:*class-name-hash-table*) new-value)))
|
|
((null new-value)
|
|
(if env
|
|
(si:proclaim-class name nil env)
|
|
(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 &rest options)
|
|
(declare (notinline ensure-generic-function))
|
|
;;(record-definition 'method `(method ,name ,@qualifiers ,specializers))
|
|
(let* ((gf (ensure-generic-function name))
|
|
(fun (wrapped-method-function 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 std-compute-discriminating-function (generic-function)
|
|
(values (unoptimized-discriminator generic-function) t))
|
|
|
|
(defun compute-discriminating-function (gf)
|
|
(declare (notinline std-compute-discriminating-function))
|
|
(std-compute-discriminating-function gf))
|
|
|
|
(defun set-generic-function-dispatch (gf)
|
|
;; We have to decide which discriminating function to install:
|
|
;; 1. One supplied by the user (or not possible to optimize in C)
|
|
;; 2. One coded in C that follows the MOP
|
|
;; 3. One in C specialized for slot accessors
|
|
;; 4. One in C specialized for standard-generic-function
|
|
;; Respectively:
|
|
;; 1. The user supplies the discriminating function[1]
|
|
;; 2. The function is not STANDARD-GENERIC-FUNCTION
|
|
;; 3. The class of all function methods is STANDARD-OPTIMIZED-*-METHOD
|
|
;; 4. The function is a STANDARD-GENERIC-FUNCTION
|
|
;;
|
|
;; This chain of reasoning uses the fact that the user is not allowed to
|
|
;; override standard methods specialized on standard classes.
|
|
;;
|
|
;; [1] We recognize that the user didn't overwrite our function by examining
|
|
;; the second value returned from C-D-F; It is also possible that C-D-F
|
|
;; disables the C optimization because it has more efficient strategy.
|
|
;;
|
|
(declare (notinline compute-discriminating-function))
|
|
(multiple-value-bind (computed-discriminator optimizable)
|
|
(compute-discriminating-function gf)
|
|
(unless (not (> (length (slot-value gf 'spec-list)) 63))
|
|
;; Code in C caches effective methods; the cache key length is 64 and
|
|
;; can't handle functions with more specializable arguments. The first
|
|
;; argument is the generic function itself.
|
|
(setf optimizable nil))
|
|
(let ((methods (slot-value gf 'methods))
|
|
(standard-generic-function-p
|
|
(eq (slot-value (class-of gf) 'name) 'standard-generic-function)))
|
|
(flet ((only-slot-accessors-p (class-name)
|
|
(and methods
|
|
(loop with class = (find-class class-name nil)
|
|
for m in methods
|
|
always (eq class (class-of m)))
|
|
class-name)))
|
|
(set-funcallable-instance-function
|
|
gf
|
|
(cond
|
|
((not optimizable) computed-discriminator)
|
|
((not standard-generic-function-p) 't)
|
|
((only-slot-accessors-p 'standard-optimized-reader-method))
|
|
((only-slot-accessors-p 'standard-optimized-writer-method))
|
|
(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)
|
|
(declare (optimize (speed 3)))
|
|
(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)))))
|
|
(let ((methods (loop for method in (generic-function-methods gf)
|
|
when (applicable-method-p method args)
|
|
collect method)))
|
|
(sort-applicable-methods gf methods (mapcar #'class-of args))))))
|
|
|
|
(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)
|
|
;; EQL specializer invalidates the computation. We still check
|
|
;; other classes because maybe later specializer will make this
|
|
;; method not applicable. -- jd 2022-01-05
|
|
(loop with eql-spec-p = nil
|
|
for spec in (method-specializers method)
|
|
for class in classes
|
|
do (if (eql-specializer-flag spec)
|
|
(let ((object (eql-specializer-object spec)))
|
|
(if (si::of-class-p object class)
|
|
(setf eql-spec-p t)
|
|
(return-from applicable-method-p nil)))
|
|
(unless (si::subclassp class spec)
|
|
(return-from applicable-method-p nil)))
|
|
finally
|
|
(if eql-spec-p
|
|
(return-from std-compute-applicable-methods-using-classes
|
|
(values nil nil))
|
|
(return t)))))
|
|
(let* ((methods (loop for method in (generic-function-methods gf)
|
|
when (applicable-method-p method classes)
|
|
collect method))
|
|
(sorted-methods (sort-applicable-methods gf methods classes)))
|
|
(values sorted-methods t)))))
|
|
|
|
(setf (fdefinition 'compute-applicable-methods)
|
|
#'std-compute-applicable-methods)
|
|
|
|
(setf (fdefinition 'compute-applicable-methods-using-classes)
|
|
#'std-compute-applicable-methods-using-classes)
|
|
|
|
(defun sort-applicable-methods (gf applicable-list args-specializers)
|
|
(declare (optimize (safety 0) (speed 3)))
|
|
(with-early-accessors (+standard-method-slots+
|
|
+standard-generic-function-slots+
|
|
+eql-specializer-slots+
|
|
+standard-class-slots+)
|
|
(let ((f (generic-function-a-p-o-function gf))
|
|
(args-classes
|
|
(loop for arg-spec in args-specializers
|
|
for req-args in (generic-function-argument-precedence-order gf)
|
|
collect (if (eql-specializer-flag arg-spec)
|
|
(class-of (eql-specializer-object arg-spec))
|
|
arg-spec))))
|
|
;; reorder args to match the precedence order
|
|
(when f
|
|
(setf args-classes (funcall f args-classes)))
|
|
;; 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 (method (cdr scan))
|
|
(when (eq (compare-methods most-specific method args-classes f)
|
|
2)
|
|
(setq most-specific method)))
|
|
(setq scan (delete most-specific scan))
|
|
(push most-specific ordered-list)))))
|
|
|
|
(defun compare-methods (method-1 method-2 args-classes 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)))
|
|
(when f
|
|
(setf specializers-list-1 (funcall f specializers-list-1))
|
|
(setf specializers-list-2 (funcall f specializers-list-2)))
|
|
(compare-specializers-lists specializers-list-1
|
|
specializers-list-2
|
|
args-classes))))
|
|
|
|
(defun compare-specializers-lists (spec-list-1 spec-list-2 args-classes)
|
|
(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-classes))
|
|
(1 '1)
|
|
(2 '2)
|
|
(=
|
|
(compare-specializers-lists (cdr spec-list-1)
|
|
(cdr spec-list-2)
|
|
(cdr args-classes)))
|
|
((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-classes))))))
|
|
|
|
(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 enough?
|
|
((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)))))
|
|
|
|
;;; The specialization profile is a sequence with as many elements as the
|
|
;;; generic function has required arguments. Each element is a cons:
|
|
;;;
|
|
;;; (CLASS-SPECIALIZED-P . EQL-SPECIALIZERS)
|
|
;;;
|
|
;;; CLASS-SPECIALIZED-P is used to determine whether the argument has a
|
|
;;; specializer for any class other than the builtin-class T.
|
|
;;;
|
|
;;; EQL-SPECIALIZERS is a list of all EQL-SPECIALIZER-OBJECTs
|
|
(defun compute-g-f-spec-list (gf)
|
|
(with-early-accessors (+standard-generic-function-slots+
|
|
+eql-specializer-slots+
|
|
+standard-method-slots+)
|
|
(flet ((nupdate-profile (spec-how-list specializers)
|
|
(if (null spec-how-list)
|
|
(loop for spec in specializers
|
|
collect (if (eql-specializer-flag spec)
|
|
(list nil (eql-specializer-object spec))
|
|
(if (eq spec (find-class t))
|
|
(cons nil nil)
|
|
(cons t nil))))
|
|
(loop for spec in specializers
|
|
for (arg-profile) on spec-how-list
|
|
do (if (eql-specializer-flag spec)
|
|
(push (eql-specializer-object spec)
|
|
(cdr arg-profile))
|
|
(when (and (not (car arg-profile))
|
|
(not (eq spec (find-class t))))
|
|
(setf (car arg-profile) t)))
|
|
finally (return spec-how-list)))))
|
|
(setf (generic-function-spec-list gf)
|
|
(reduce #'nupdate-profile (generic-function-methods gf)
|
|
:key #'method-specializers :initial-value nil))
|
|
(let ((function nil)
|
|
(a-p-o (generic-function-argument-precedence-order gf))
|
|
(gf-ll (generic-function-lambda-list gf)))
|
|
(when (consp gf-ll)
|
|
(let ((required-arguments (rest (si::process-lambda-list gf-ll 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)))
|