diff --git a/src/CHANGELOG b/src/CHANGELOG index fff9f5220..f68fad7e8 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -77,6 +77,9 @@ ECL 12.2.2: - The method combination slot of a generic function is now precomputed by using FIND-METHOD-COMBINATION in SHARED-INITIALIZE. + - METHOD-COMBINATION is now a class with slots and it is used by ECL for + computing effective methods. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/c/instance.d b/src/c/instance.d index 4c5f9dd7b..584763520 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -257,7 +257,6 @@ enum ecl_built_in_classes { ECL_BUILTIN_SYMBOL, ECL_BUILTIN_NULL, ECL_BUILTIN_KEYWORD, - ECL_BUILTIN_METHOD_COMBINATION, ECL_BUILTIN_PACKAGE, ECL_BUILTIN_FUNCTION, ECL_BUILTIN_PATHNAME, diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index cc0c93440..aa5869c9b 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -66,6 +66,7 @@ (make-empty-standard-class 'FUNCALLABLE-STANDARD-CLASS standard-class)) (metaobject (make-empty-standard-class 'METAOBJECT standard-class)) + (method-combination (make-empty-standard-class 'METHOD-COMBINATION standard-class)) (specializer (make-empty-standard-class 'SPECIALIZER standard-class)) (eql-specializer (make-empty-standard-class 'EQL-SPECIALIZER standard-class)) (the-class (make-empty-standard-class 'CLASS standard-class)) @@ -79,6 +80,7 @@ (add-slots std-class #1='#.(remove-accessors +standard-class-slots+)) (add-slots standard-class #1#) (add-slots funcallable-standard-class #1#) + (add-slots method-combination '#.(remove-accessors +method-combination-slots+)) (add-slots specializer '#.(remove-accessors +specializer-slots+)) (add-slots eql-specializer '#.(remove-accessors +eql-specializer-slots+)) @@ -116,19 +118,22 @@ (class-direct-superclasses standard-object) (list the-t) (class-direct-subclasses standard-object) (list metaobject) (class-direct-superclasses metaobject) (list standard-object) - (class-direct-subclasses metaobject) (list specializer) + (class-direct-subclasses metaobject) (list specializer method-combination) + (class-direct-superclasses method-combination) (list metaobject) (class-direct-superclasses specializer) (list metaobject) (class-direct-subclasses specializer) (list the-class eql-specializer) (class-direct-superclasses eql-specializer) (list specializer) (class-direct-superclasses the-class) (list specializer) (class-direct-subclasses the-class) (list std-class) (class-direct-superclasses std-class) (list the-class) + (class-direct-subclasses std-class) (list standard-class funcallable-standard-class) (class-direct-superclasses standard-class) (list std-class) (class-direct-superclasses funcallable-standard-class) (list std-class)) (si::instance-sig-set the-t) (si::instance-sig-set standard-object) (si::instance-sig-set metaobject) + (si::instance-sig-set method-combination) (si::instance-sig-set specializer) (si::instance-sig-set eql-specializer) (si::instance-sig-set the-class) @@ -144,6 +149,8 @@ (setf cpl (list* standard-object cpl)) (class-precedence-list metaobject) (setf cpl (list* metaobject cpl)) + (class-precedence-list method-combination) + (list* method-combination cpl) (class-precedence-list specializer) (setf cpl (list* specializer cpl)) (class-precedence-list eql-specializer) diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index aab49df0a..0c6c4b34d 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -33,7 +33,8 @@ :direct-superclasses (list (find-class 'class)) :direct-slots nil)) -(si:instance-class-set (find-class 't) (find-class 'built-in-class)) +(si:instance-class-set +the-t-class+ (find-class 'built-in-class)) +(si::instance-sig-set +the-t-class+) (defmethod make-instance ((class built-in-class) &rest initargs) (declare (ignore initargs)) @@ -76,7 +77,6 @@ (symbol) (null symbol list) (keyword symbol) - (method-combination) (package) (function) (pathname) diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index 3f675e3fa..226a57125 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -198,17 +198,19 @@ (setf (gethash name *method-combinations*) function)) name) -(defun method-combination-object-p (o) - (and (listp o) - (= (length o) 3) - (eq (first o) - (mp:with-lock (*method-combinations-lock*) - (gethash (third o) *method-combinations*))))) +(defun make-method-combination (name compiler options) + (let ((o (si:allocate-raw-instance nil (find-class 'method-combination) + #.(length +method-combination-slots+)))) + (setf (method-combination-compiler o) compiler + (method-combination-name o) name + (method-combination-options o) options) + o)) (defun find-method-combination (gf method-combination-type-name method-combination-options) - (list (search-method-combination method-combination-type-name) - method-combination-options - method-combination-type-name)) + (make-method-combination method-combination-type-name + (search-method-combination method-combination-type-name) + method-combination-options + )) (defun define-simple-method-combination (name &key documentation identity-with-one-argument @@ -321,14 +323,11 @@ ;;; (defun std-compute-effective-method (gf method-combination applicable-methods) - (let* ((method-combination-function (first method-combination)) - (method-combination-args (second method-combination))) - (if method-combination-args - (apply method-combination-function - gf applicable-methods - method-combination-args) - (funcall method-combination-function - gf applicable-methods)))) + (let* ((compiler (method-combination-compiler method-combination)) + (options (method-combination-options method-combination))) + (if options + (apply compiler gf applicable-methods options) + (funcall compiler gf applicable-methods)))) ;; ;; These method combinations are bytecompiled, for simplicity. diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 007904119..d219989f7 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -159,7 +159,7 @@ gfun lambda-list))) (call-next-method) (let ((combination (generic-function-method-combination gfun))) - (unless (method-combination-object-p combination) + (unless (typep combination 'method-combination) (setf (generic-function-method-combination gfun) (find-method-combination gfun (first combination) (rest combination))))) (when (and l-l-p (not a-o-p)) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 845bf2fef..080c8bcb3 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -74,6 +74,17 @@ #.(create-accessors +eql-specializer-slots+ 'eql-specializer) +;;; ---------------------------------------------------------------------- +;;; Class METHOD-COMBINATION + +(eval-when (compile eval) + (defparameter +method-combination-slots+ + `((name :initform :name :accessor method-combination-name) + (compiler :initform :compiler :accessor method-combination-compiler) + (options :initform :options :accessor method-combination-options)))) + +#.(create-accessors +method-combination-slots+ 'method-combination) + ;;; ---------------------------------------------------------------------- ;;; Class CLASS @@ -126,7 +137,7 @@ :accessor generic-function-name) (spec-list :initform nil :accessor generic-function-spec-list) (method-combination - :initarg :method-combination :initform '(standard-compute-effective-method nil standard) + :initarg :method-combination :initform (find-method-combination nil 'standard nil) :accessor generic-function-method-combination) (lambda-list :initarg :lambda-list :accessor generic-function-lambda-list)