Attempting to hook the no-applicable-method generic in order to allow method delegation breaks in guile 1.6.8. Any method added to no-applicable-method that does not throw an error causes a bus error in scm_deval.
Reproduction:
1. Create a file containing the following:
(use-modules (oop goops))
(define-class <delegator> ()
(target #:getter target #:init-keyword #:target))
(define-class <target> ())
(define-method (hello (t <target>))
(display "hello.")
(display #\newline))
(define-method (no-applicable-method (gf <generic>) args)
(cond ((or (null? args) (not (is-a? (car args) <delegator>)))
(goops-error "No applicable method for ~S in call ~S"
gf (cons (generic-function-name gf) args)))
(else
(apply gf (cons (target (car args)) (cdr args))))))
(hello (make <delegator> #:target (make <target>)))
2. Load the file.
==>
Hello.
Bus error
Discussion:
The crash occurs in scm_deval near line 2414:
case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
....
<snip>
....
apply_cmethod:
env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
arg2,
SCM_CMETHOD_ENV (z));
SCM_CMETHOD_CODE (z) is NULL and SCM_CAR crashes. Making the following change
apply_cmethod:
if (!SCM_CMETHOD_CODE (z))
return SCM_EOL;
env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
arg2,
SCM_CMETHOD_ENV (z));
fixes the crash, but the value returned by the method is lost.
A change to the initialize method for <generic> fixes the problem, but with two notable side-effects.
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(name (get-keyword #:name initargs #f)))
(next-method)
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
(list (make <method>
#:specializers <top>
#:procedure
(lambda l
(apply previous-definition
l))))
<original>
'()))
</original>
<patch>
(list (make <method>
#:specializers <top>
#:procedure
(lambda args
(no-applicable-method generic args))))))
</patch>
(if name
(set-procedure-property! generic 'name name))
))
The cost is that every generic function has at least one method by default, and that no-next-method is not called in the following:
(define-class <pong> ())
(define-method (ping (p <pong>)) (next-method))
(ping (make <pong>))
==>
<unnamed port>: In _expression_ (let (#) (next-method)):
<unnamed port>: No applicable method for #<<generic> ping (2)> in call (ping #<<pong> 3b900>)
ABORT: (goops-error)
_______________________________________________ Bug-guile mailing list [email protected] http://lists.gnu.org/mailman/listinfo/bug-guile
