GOOPS: define-method* with extended lambda-list-syntax?

[Anders Vinjar]

A question for anyone having a better knowledge than me about
development around GOOPS.  

In translating a piece of CLTL to Guile, I would need a
procedure/macro define-method* which gives access to extended
lambda-list syntax (ie. with #:optional #:key etc) parameters.

Q: is there something like this available anywhere already?

Q2: if not, is having this in CLOS a big design-flaw, making my
attempts here just silly?

I did an attempt at building a define-method* macro, which sort
of works, but it seems very inefficient.  Im sure there are flaws
with it i havent ran across yet because of lack of knowledge.


(define-method* (f (x <real>) (y <top>) #:optional z)
    'real-top)

expands into 2 calls on add-method! - one with specialiser for

        (list <real> <top>)

- the other for

        (list <real> <top> <top>)

The procedure-slot is the same for both methods.

guile> (generic-function-methods f)
=> (#<<method> (<real> <top>) 808c060> #<<method> (<real> <top> <top>) 808c090>)


Heres the define-method* macro ive put together this far.  (It
uses a procedure parse-lambda-list which just divides the various
elements of an extended lambda list into sublists.  Limiting to
#:optional-arguments for now while testing.)

(defmacro define-method* (name-pars . body)
  (let ((name (car name-pars))
        (pars (cdr name-pars)))
    (multiple-value-bind
          (reqs opts rest keys aok? auxs)
        (parse-lambda-list pars)
      (let* ((specsr (map (lambda (y) (if (list? y) (cadr y)))
                          reqs))
             (specs (append specsr
                            (map (lambda (y)
                                   (if (cadr y)
                                     (class-name (class-of (cadr y)))
                                     '<top>))
                                 opts)))
             (llist (append (map (lambda (y) (if (list? y) (car y) y)) reqs)
                            (list #:optional)
                            opts)))
        (cond ((defined? name)
               `(begin
                 (if (not ,name)
                   (define-generic ,name))
                 (add-method! ,name
                  (make-method (list ,@specs)
                   (lambda* ,llist ,@body)))
                 (add-method! ,name
                  (make-method (list ,@specsr)
                   (lambda* ,llist ,@body)))))
              (else
               `(begin
                 (define-generic ,name)
                 (add-method! ,name
                  (make-method (list ,@specs)
                   (lambda* ,llist ,@body)))
                 (add-method! ,name
                  (make-method (list ,@specsr)
                   (lambda* ,llist ,@body))))))))))


(define-method* (f (x <real>) (y <integer>) #:optional z)
    (list 'real-integer z))

(define-method* (f (x <real>) (y <top>) #:optional z)
    (list 'real-top z))

(define-method* (f (x <real>) (y <real>) #:optional z)
    (list 'real-real z))



--

Anders Vinjar - NoTAM