mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 23:50:56 -08:00
Code Issues Projects Releases Packages Wiki Activity

Method combinations implemented. Bug involving EQL specializers not being compared with EQL solved.

Browse source
This commit is contained in:
jjgarcia 2003-07-16 17:30:18 +00:00
parent a2ab24e4d8
commit 47fdf3eebe
10 changed files with 197 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

5
src/CHANGELOG
View file

@ -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:
=====

12
src/c/gfun.d
View file

@ -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

5
src/c/symbols_list.h
View file

@ -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},

120
src/clos/combin.lsp
View file

@ -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)))

33
src/clos/fixup.lsp
View file

@ -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

69
src/clos/generic.lsp
View file

@ -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

13
src/clos/kernel.lsp
View file

@ -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)))

3
src/clos/macros.lsp
View file

@ -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")

15
src/clos/method.lsp
View file

@ -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)))

21
src/clos/standard.lsp
View file

@ -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)))
;;;----------------------------------------------------------------------