From 47fdf3eebeb055f93d7221253ccf91f772564084 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 16 Jul 2003 17:30:18 +0000 Subject: [PATCH] Method combinations implemented. Bug involving EQL specializers not being compared with EQL solved. --- src/CHANGELOG | 5 ++ src/c/gfun.d | 12 ++--- src/c/symbols_list.h | 5 +- src/clos/combin.lsp | 120 ++++++++++++++++++++++++++++++++++++++++-- src/clos/fixup.lsp | 33 +++++++++--- src/clos/generic.lsp | 69 +++++++----------------- src/clos/kernel.lsp | 13 +++-- src/clos/macros.lsp | 3 +- src/clos/method.lsp | 15 ++---- src/clos/standard.lsp | 21 ++++---- 10 files changed, 197 insertions(+), 99 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 2604b374e..7ce350bb9 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1447,6 +1447,9 @@ ECLS 0.9b - ENSURE-DIRECTORIES-EXIST was broken. + - EQL specializers were compared to the arguments using EQ instead + of EQL. + * Visible changes: - New special form C-INLINE, allows inserting C/C++ code in any @@ -1532,6 +1535,8 @@ ECLS 0.9b :DEFAULT, as ECL does not support the notion of external formats (all streams have element type (UNSIGNED-BYTE 8)). + - Method combinations are now fully supported. + TODO: ===== diff --git a/src/c/gfun.d b/src/c/gfun.d index eb6d5f96d..d0ef87f99 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -206,14 +206,14 @@ compute_method(int narg, cl_object fun, cl_object *args) for (i = 0, spec_no = 0; i < fun->gfun.arg_no; i++, spec_how++) { if (*spec_how != Cnil) argtype[spec_no++] = (ATOM(*spec_how) || - !member_eq(args[i], *spec_how)) ? + Null(memql(args[i], *spec_how))) ? cl_type_of(args[i]) : args[i]; } e = get_meth_hash(argtype, spec_no, fun->gfun.method_hash); - if (e->key == OBJNULL) { + if (e->key == OBJNULL) { /* method not cached */ register cl_object gf = fun->gfun.instance; cl_object methods, meth_comb, meth_args, arglist = Cnil; @@ -222,11 +222,9 @@ compute_method(int narg, cl_object fun, cl_object *args) while (i-- > 0) arglist = CONS(args[i], arglist); methods = funcall(3, @'compute-applicable-methods', gf, arglist); - meth_comb = funcall(2, @'si::generic-function-method-combination', gf); - meth_args = funcall(2, @'si::generic-function-method-combination-args', gf); - func = funcall(5, @'si::compute-effective-method', gf, methods, - meth_comb, meth_args); - + meth_comb = instance_ref(gf, 2); + func = funcall(4, @'si::compute-effective-method', gf, meth_comb, + methods); /* update cache */ set_meth_hash(argtype, spec_no, fun->gfun.method_hash, func); } else diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 0f1b978d7..d03412753 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -961,6 +961,7 @@ cl_symbols[] = { {"MAKE-METHOD", CL_ORDINARY, NULL, -1}, {"METHOD", CL_ORDINARY, NULL, -1}, {"METHOD-COMBINATION-ERROR", CL_ORDINARY, NULL, -1}, +{"METHOD-COMBINATION", CL_ORDINARY, NULL, -1}, {"METHOD-QUALIFIERS", CL_ORDINARY, NULL, -1}, {"NEXT-METHOD-P", CL_ORDINARY, NULL, -1}, {"NO-APPLICABLE-METHOD", CL_ORDINARY, NULL, -1}, @@ -1033,7 +1034,6 @@ cl_symbols[] = { {SYS_ "COERCE-TO-PACKAGE", SI_ORDINARY, si_coerce_to_package, 1}, {SYS_ "COMPILED-FUNCTION-BLOCK", SI_ORDINARY, si_compiled_function_block, 1}, {SYS_ "COMPILED-FUNCTION-NAME", SI_ORDINARY, si_compiled_function_name, 1}, -{SYS_ "COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1}, {SYS_ "COPY-STREAM", SI_ORDINARY, si_copy_stream, 1}, {SYS_ "DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, si_daylight_saving_time_p, -1}, {SYS_ "DISPATCH-FUNCTION-P", SI_ORDINARY, si_dispatch_function_p, 1}, @@ -1050,8 +1050,6 @@ cl_symbols[] = { {SYS_ "FRS-TOP", SI_ORDINARY, si_frs_top, 0}, {SYS_ "FSET", SI_ORDINARY, si_fset, -1}, {SYS_ "FUNCTION-BLOCK-NAME", SI_ORDINARY, si_function_block_name, 1}, -{SYS_ "GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, NULL, -1}, -{SYS_ "GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, NULL, -1}, {SYS_ "GET-LOCAL-TIME-ZONE", SI_ORDINARY, si_get_local_time_zone, 0}, {SYS_ "GET-SYSPROP", SI_ORDINARY, si_get_sysprop, 2}, {SYS_ "GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1}, @@ -1146,6 +1144,7 @@ cl_symbols[] = { #else {SYS_ "ALLOCATE-GFUN", SI_ORDINARY, si_allocate_gfun, 3}, {SYS_ "CHANGE-INSTANCE", SI_ORDINARY, si_change_instance, 4}, +{SYS_ "COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1}, {SYS_ "GFUN-NAME", SI_ORDINARY, si_gfun_name, 1}, {SYS_ "GFUN-NAME-SET", SI_ORDINARY, si_gfun_name_set, 2}, {SYS_ "GFUN-METHOD-HT", SI_ORDINARY, si_gfun_method_ht, 1}, diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index d502cf0f4..717e53f87 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -256,14 +256,14 @@ (collect-forms forms) (cons 'PROGN progn-form)))) -(defun error-qualifiers (m qualifiers) +(defun error-qualifier (m qualifier) (declare (si::c-local)) (error "Standard method combination allows only one qualifier ~ per method, either :BEFORE, :AFTER, or :AROUND; while ~ a method with ~S was found." - m qualifiers)) + m qualifier)) -(defun standard-compute-combined-method (gf methods) +(defun standard-compute-effective-method (gf methods) (declare (ignore gf)) (let*((before ()) (primary ()) @@ -281,7 +281,7 @@ ;; When there are no primary methods, an error is to be signaled, ;; and we need not care about :AROUND, :AFTER or :BEFORE methods. (when (null primary) - (return-from standard-compute-combined-method + (return-from standard-compute-effective-method #'(lambda (&rest args) (apply 'no-primary-method gf args)))) (setq before (nreverse before) @@ -306,3 +306,115 @@ (,@(rest around) (MAKE-METHOD ,main-effective-method))) main-effective-method)))))) + +;; ---------------------------------------------------------------------- +;; DEFINE-METHOD-COMBINATION +;; +;; METHOD-COMBINATION objects are just a list +;; (name arg*) +;; where NAME is the name of the method combination type defined with +;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments. +;; +;; For each method combination type there is an associated function, +;; and the list of all known method combination types is kept in +;; *METHOD-COMBINATIONS* in the form of property list: +;; (mc-type-name1 function1 mc-type-name2 function2 ....) +;; +;; FUNCTIONn is the function associated to a method combination. It +;; is of type (FUNCTION (generic-function method-list) FUNCTION), +;; and it outputs an anonymous function which is the effective method. +;; + +(defvar *method-combinations* '()) + +(defun install-method-combination (name function) + (setf (getf *method-combinations* name) function) + name) + +(defun define-simple-method-combination (name &key documentation + identity-with-one-argument + (operator name)) + (declare (si::c-local)) + `(define-method-combination + ,name (&key (order :MOST-SPECIFIC-FIRST)) + ((around (:AROUND)) + (principal (,name) :REQUIRED t)) + (let ((main-effective-method + `(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL)) + principal)))) + (cond (around + `(call-method ,(first around) + (,@(rest around) (make-method ,main-effective-method)))) + (,(if identity-with-one-argument + '(rest principal) + t) + main-effective-method) + (t (second main-effective-method)))))) + +(defun define-complex-method-combination (form) + (declare (si::c-local)) + (flet ((syntax-error () + (error "~S is not a valid DEFINE-METHOD-COMBINATION form" + whole))) + (destructuring-bind (name lambda-list method-groups &rest body &aux + (group-names '()) + (group-checks '()) + (group-after '()) + (generic-function '.generic-function.) + (method-arguments '())) + form + (unless (symbolp name) (syntax-error)) + (let ((x (first body))) + (when (and (consp x) (eql (first x) :ARGUMENTS)) + (error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION."))) + (let ((x (first body))) + (when (and (consp x) (eql (first x) :GENERIC-FUNCTION)) + (setf body (rest body)) + (unless (symbolp (setf generic-function (second x))) + (syntax-error)))) + (dolist (group method-groups) + (destructuring-bind (name predicate &key description + (order :most-specific-first) (required nil)) + group + (if (symbolp name) + (push name group-names) + (syntax-error)) + (setf condition + (cond ((eql predicate '*) 'T) + ((symbolp predicate) `(,predicate .METHOD-QUALIFIERS.)) + ((and (listp predicate) + (let* ((q (last predicate 0)) + (p (copy-list (butlast predicate 0)))) + (when (every #'symbolp p) + (if (eql q '*) + `(every #'equal ',p .METHOD-QUALIFIERS.) + `(equal ',p .METHOD-QUALIFIERS.)))))) + (t (syntax-error)))) + (push `(,condition (push .METHOD. ,name)) group-checks) + (when required + (push `(unless ,name + (invalid-method-error "Method combination: ~S. No methods ~ + in required group ~S." ,name)) + group-after)) + (case order + (:most-specific-first + (push `(setf ,name (nreverse ,name)) group-after)) + (:most-specific-last) + (otherwise (syntax-error))))) + `(install-method-combination ',name + (lambda-block ,name (,generic-function .methods-list. ,@lambda-list) + (let (,@group-names) + (dolist (.method. .methods-list.) + (let ((.method-qualifiers. (get-method-qualifiers .method.))) + (cond ,@(nreverse group-checks) + (t (invalid-method-error .method. + "Method qualifiers ~S are not allowed in the method~ + combination ~S." .method-qualifiers. ,name))))) + ,@group-after + (make-effective-method-function ,@body)))) + ))) + +(defmacro define-method-combination (name &body body) + (if (and body (listp (first body))) + (define-complex-method-combination (list* name body)) + (apply #'define-simple-method-combination name body))) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index ed0237fcb..5288cb185 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -197,13 +197,19 @@ (si::c-local)) (error "Complex type specifiers are not yet supported.")) -(defun si:compute-effective-method (gf applicable-methods - method-combination-type - method-combination-args) +(defun compute-effective-method (gf method-combination applicable-methods) (declare (ignore method-combination-type method-combination-args)) - (if applicable-methods - (standard-compute-combined-method gf applicable-methods) - (no-applicable-method gf))) + (if (not applicable-methods) + (no-applicable-method gf) + (let* ((method-combination-name (car method-combination)) + (method-combination-args (cdr method-combination))) + (if (eq method-combination-name 'STANDARD) + (standard-compute-effective-method gf applicable-methods) + (apply (or (getf *method-combinations* method-combination-name) + (error "~S is not a valid method combination object" + method-combination)) + gf applicable-methods + method-combination-args))))) (defmethod no-applicable-method (gf &rest args) (declare (ignore args)) @@ -218,6 +224,21 @@ (error "Generic function: ~A. No primary method given arguments: ~S" (si:gfun-name (generic-function-dispatcher gf)) args)) +;; +;; These method combinations are bytecompiled, for simplicity. +;; +(eval '(progn + (defclass method-combination (t) ()) + (define-method-combination progn :identity-with-one-argument t) + (define-method-combination and :identity-with-one-argument t) + (define-method-combination max :identity-with-one-argument t) + (define-method-combination + :identity-with-one-argument t) + (define-method-combination nconc :identity-with-one-argument t) + (define-method-combination append :identity-with-one-argument nil) + (define-method-combination list :identity-with-one-argument nil) + (define-method-combination min :identity-with-one-argument t) + (define-method-combination or :identity-with-one-argument t))) + ;;; ---------------------------------------------------------------------- ;;; Redefinition Protocol diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index c7b2a2563..1da9c9fe3 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -150,17 +150,12 @@ (if documentation (error "Option :documentation specified more than once") (setq documentation - (parse-legal-documentation - (second option))))) + (parse-legal-documentation (second option))))) (:method-combination (if method-combination (error "Option :method-combination specified more than \ once") - (setq method-combination - ;(parse-legal-method-combination - ;(second option)) - ; until method-combination is implemented - (second option)))) + (setq method-combination (rest option)))) (:generic-function-class (if generic-function-class (error "Option :generic-function-class specified more \ @@ -179,27 +174,26 @@ than once") (error "~S is not a legal defgeneric option" (first option))))) (values argument-precedence-order declaration documentation - method-combination generic-function-class method-class + (or method-combination '(STANDARD)) + generic-function-class method-class method-list))) -(defun ensure-generic-function (function-specifier - &key lambda-list - argument-precedence-order - declare - documentation - (generic-function-class - 'STANDARD-GENERIC-FUNCTION) - (method-combination 'STANDARD) +(defun ensure-generic-function (function-specifier &rest args &key + lambda-list + (generic-function-class 'STANDARD-GENERIC-FUNCTION) (method-class 'STANDARD-METHOD) - environment) + &allow-other-keys) (unless (LEGAL-GENERIC-FUNCTION-NAME-P function-specifier) (error "Generic function ~A has incorrect function specifier (a non-nil symbol, a list whose car is SETF)" function-specifier)) (when (LEGAL-GENERIC-FUNCTION-P function-specifier) + (setf args (copy-list args)) + (remf args :generic-function-class) + (remf args :declare) + (remf args :environment) (unless (classp method-class) - (setq method-class - (find-class method-class))) + (setf (getf args :method-class) (find-class method-class))) (let (dispatcher gf-object) (if (and (fboundp function-specifier) @@ -207,16 +201,8 @@ than once") ;; modify the existing object (progn - (setf gf-object - (si:gfun-instance dispatcher) - (slot-value gf-object 'ARGUMENT-PRECEDENCE-ORDER) - argument-precedence-order - (slot-value gf-object 'DOCUMENTATION) - documentation - (generic-function-method-combination gf-object) - method-combination - (slot-value gf-object 'METHOD-CLASS) - method-class) + (setf gf-object (si:gfun-instance dispatcher) + gf-object (apply #'reinitialize-instance gf-object args)) ;;(if (or ;; (not (method-exist-p function-specifier)) ;; (congruent-lambda-list-p lambda-list @@ -229,17 +215,11 @@ than once") ) ;; else create a new generic function object (setf dispatcher (make-gfun function-specifier lambda-list) - gf-object (make-instance - generic-function-class - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order - :method-combination method-combination - :method-class method-class - :documentation documentation - :gfun dispatcher) - (si:gfun-instance dispatcher) gf-object - (fdefinition function-specifier) dispatcher)) - gf-object))) + gf-object (apply #'make-instance generic-function-class args))) + (setf (si:gfun-instance dispatcher) gf-object + (gfun gf-object) dispatcher + (fdefinition function-specifier) dispatcher) + gf-object)))) ;;; ---------------------------------------------------------------------- ;;; congruence @@ -330,15 +310,6 @@ than once") (error "The documentation must be a string")) doc) -(defun parse-legal-method-combination (name args) - (declare (si::c-local)) - (unless (method-combination-p name) - (error "~A is not the name of a method-combination type" name)) - (unless (legal-method-combination-args name args) - (error "~S are not legal args for the method combination type ~A" - args name)) - (values name args)) - (defun legal-generic-function-classp (class-name) (declare (si::c-local)) ; until we don't know when a class can be the class of a generic function diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index d5a87ec5c..35150af0f 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -108,9 +108,9 @@ (defun method-class (gfun) 'standard-method) -(defun methods (gf) (si:instance-ref gf 7)) +(defun methods (gf) (si:instance-ref gf 6)) -;(defun generic-function-dispatcher (gf) (si:instance-ref gf 6)) anticipata +;(defun generic-function-dispatcher (gf) (si:instance-ref gf 5)) anticipata (defun make-gfun (name lambda-list) (let* ((nargs @@ -150,11 +150,10 @@ (si:instance-set gf-object 0 lambda-list) ; lambda-list (si:instance-set gf-object 1 'default) ; argument-precedence-order - (si:instance-set gf-object 2 'standard) ; method-combination - (si:instance-set gf-object 3 nil) ; method-combination-arguments - (si:instance-set gf-object 5 nil) ; documentation - (si:instance-set gf-object 6 gfun) ; gfun - (si:instance-set gf-object 7 nil) ; methods + (si:instance-set gf-object 2 '(standard)) ; method-combination + (si:instance-set gf-object 4 nil) ; documentation + (si:instance-set gf-object 5 gfun) ; gfun + (si:instance-set gf-object 6 nil) ; methods (si:gfun-instance-set gfun gf-object) (setf (fdefinition name) gfun))) diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index c8c03919d..5d1855f53 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -9,7 +9,8 @@ (defpackage "CLOS" (:use "WALKER" "CL") - (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP")) + (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" + "COMPUTE-EFFECTIVE-METHOD")) (in-package "CLOS") diff --git a/src/clos/method.lsp b/src/clos/method.lsp index df767afed..430d763c7 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -570,7 +570,7 @@ (defun method-needs-next-methods-p (method) (getf (nth 5 method) :needs-next-methods-p)) -(defun generic-function-dispatcher (gf) (si:instance-ref gf 6)) +(defun generic-function-dispatcher (gf) (si:instance-ref gf 5)) ;;; early version used during bootstrap (defun add-method (gf method) @@ -660,19 +660,12 @@ (nreverse methods)))) -(defun si:generic-function-method-combination (gf)) - -(defun si:generic-function-method-combination-args (gf)) - -(defun si:compute-effective-method (gf applicable-methods - method-combination-type - method-combination-args) - (declare (ignore method-combination-type method-combination-args)) +(defun compute-effective-method (gf method-combination applicable-methods) + (declare (ignore method-combination)) ; the simplest case (if applicable-methods (make-effective-method-function - `(call-method ,(first applicable-methods) - ,(cdr applicable-methods))) + `(call-method ,(first applicable-methods) ,(cdr applicable-methods))) (no-applicable-method gf))) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index f9859eec3..589adfe57 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -573,6 +573,12 @@ ;;; ---------------------------------------------------------------------- ;;; Standard Generic Function ;;; ---------------------------------------------------------------------- +;; +;; The order of the slots in the STANDARD-GENERIC-FUNCTION is extremely +;; important, because the C core (gfun.d) and the bootstrap process +;; (kernel.lsp, method.lsp) access them directly, and not via generic +;; functions. +;; (defclass standard-generic-function (generic-function) ((lambda-list :initarg :lambda-list :accessor lambda-list) @@ -580,18 +586,11 @@ :initarg :argument-precedence-order :accessor generic-function-argument-precedence-order) (method-combination - :initarg :method-combination - :accessor generic-function-method-combination - ) - (method-combination-arguments - :initarg :method-combination-arguments - :accessor generic-function-method-combination-arguments - ) + :initarg :method-combination :initform '(STANDARD) + :accessor generic-function-method-combination) (method-class :initarg :method-class) - (documentation :initarg :documentation -; :accessor documentation - ) + (documentation :initarg :documentation) (gfun :initarg :gfun :accessor gfun :initform nil) - (methods :initform nil :accessor methods))) ; 7th slot as in kernel.lsp + (methods :initform nil :accessor methods))) ;;;----------------------------------------------------------------------