Bus error on non-trivial methods of no-applicable-method

[Pat Lasswell]

Summary:

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)