chicken-users
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: [Chicken-users] tinyclos and variable argument functions


From: felix winkelmann
Subject: Re: [Chicken-users] tinyclos and variable argument functions
Date: Thu, 7 Apr 2005 07:20:47 +0200

On Apr 6, 2005 5:50 PM, John Lenz <address@hidden> wrote:
> 
> No, it doesn't.  The way define-method is written, in the first define
> method the list of specializers is (<top>).  That is, define method passes
> a list of specializers that is one shorter than the actual argument lists.
> Try something like the following:
> 
> (define (printspecs var sym specs function)
>    (print specs))
> 
> (define <top> 'top)
> 
> (set! ##tinyclos#add-global-method printspecs)
> 
> (define-method (foo (a <top>) b) (print "hey"))
> (define-method (foo (a <top>) (b <top>)) (print "yo"))
> (define-method (foo (a <top>) b (c <top>)) (print "2"))
> 
> You can see that the first one prints
> (top)
> and the second prints
> (top top)
> 
> The reason is because define-method stops processing the list of arguments
> when it checks and sees there are no more pairs left in the list.  (See the
> scan function).
> 

Yes, you're right. Here is a different version, that specializes all
arguments:

(define-macro (define-method head . body)
  (##sys#check-syntax 'define-method head '(symbol . _))
  (##sys#check-syntax 'define-method body '#(_ 1))
  (let gather ([args (##sys#slot head 1)]
               [specs '()]
               [vars '()] )
    (if (or (not (pair? args)) 
            (memq (car args) '(#!optional #!key #!rest)))
        (let ([name (##sys#slot head 0)])
          `(##core#set! ,name
                        (##tinyclos#add-global-method
                         (##core#global-ref ,name)
                         ',name
                         (list ,@(reverse specs))
                         (##core#named-lambda ,name (call-next-method 
,@(reverse vars)
,@args) ,@body) ) ) )
        (let ([arg (##sys#slot args 0)])
          (gather (##sys#slot args 1)
                  (cons (if (pair? arg) (cadr arg) '<top>) specs)
                  (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) )


cheers,
felix



reply via email to

[Prev in Thread] Current Thread [Next in Thread]