[gambit-list] Generic functions with Gambit

Marc Feeley feeley at IRO.UMontreal.CA
Tue Mar 20 10:24:48 EDT 2012


On 2012-03-19, at 11:17 PM, mikel evins wrote:

> Marc,
> 
> We're considering building the Bard interpreter into the Nelson game framework. Bard implements CLOS-stye generic functions. I wonder if Gambit provides a way to make that more convenient than the ways I've done it in the past?
> 
> What I'd like to do if I can is define generic functions and methods as objects for which the following hold true:
> 
> 1. generic function is a distinct type that I can distinguish with a predicate
> 2. the same is true of method
> 3. I can ask a generic function for its method table and modify it
> 4. generic function and method are both callable, like Scheme procedures
> 
> Again, I can solve these problems with various techniques, but what would be really convenient would be a way to define a callable data type. If that's not supported by the current Gambit runtime, no sweat; I can fall back to the tricks I've used before.

[I think this is of general interest to the Gambit community, so I am CCing to the Gambit mailing list and changing the subject of the message]

Generic functions can be obtained by combining a table of methods and a closure.  That is, the table of methods is a free variable of the closure.  To get the method table from a generic function, you have to access this free variable.  Note that there is only one free variable per generic function.  Accessing this free variable can be done with the (##closure-ref genfun 1) primitive (for compiled closures), and with (##vector-ref (##interp-procedure-rte genfun) 1) (for an interpreted closure).  See the file genfun1.scm below.

Another approach is to represent generic functions with a type that is different from procedures, and to install an exception handler which will be invoked by the procedure call mechanism when it detects that the function position of the call is not a procedure.  See the file genfun2.scm below.

The performance of both approaches could be improved by a better strategy for encoding type identifiers and the hash table of methods.  I expect the approach based on closures to be the faster of the two approaches because it allocates less.

Marc

;; File: "genfun1.scm"

;;-----------------------------------------------------------------------------

(define-macro (define-generic pattern)
  (let ((name (car pattern))
        (params (cdr pattern)))
    `(define ,name
       (let (($methods
              (make-table
               init: (lambda args
                       (error "no method for call"
                              (cons ',name (map ##inverse-eval args)))))))
         (lambda ,params
           ((table-ref $methods
                       (vector ,@(map (lambda (p) `(type-identifier ,p))
                                      params)))
            , at params))))))

(define-macro (define-method pattern . body)
  (let ((name (car pattern))
        (params (map car (cdr pattern)))
        (type-ids (map cadr (cdr pattern))))
    `(table-set! (generic-function-methods ,name)
                 ',(list->vector type-ids)
                 (lambda ,params , at body))))

(define (type-identifier obj)
  (cond ((number? obj)    'number)
        ((string? obj)    'string)
        ((symbol? obj)    'symbol)
        ((boolean? obj)   'boolean)
        ((null? obj)      'null)
        ((pair? obj)      'pair)
        ((vector? obj)    'vector)
        ((procedure? obj) 'procedure)
        (else             'other)))

(define (generic-function-methods proc)
  (cond ((##interp-procedure? proc)
         (##vector-ref (##interp-procedure-rte proc) 1))
        ((##closure? proc)
         (##closure-ref proc 1))
        (else
         (error "generic function expected"))))

;;-----------------------------------------------------------------------------

;; Tests.

(define-generic (add x y))

(define-method (add (x number) (y number))
  (+ x y))

(define-method (add (x string) (y string))
  (string-append x y))

(define-method (add (x string) (y number))
  (string-append x (number->string y)))

(define-method (add (x number) (y string))
  (string-append (number->string x) y))

(pp (table->list (generic-function-methods add)))

(pp (add 11 22))
(pp (add "foo" "bar"))
(pp (add "foo" 99))
(pp (add 99 "foo"))
(pp (add #t #f))

;; output:
;;
;; ((#(string number) . #<procedure #2>)
;;  (#(string string) . #<procedure #3>)
;;  (#(number string) . #<procedure #4>)
;;  (#(number number) . #<procedure #5>))
;; 33
;; "foobar"
;; "foo99"
;; "99foo"
;; *** ERROR IN "genfun1.scm"@71.5 -- no method for call (add #t #f)

;;-----------------------------------------------------------------------------

==================================================================================================

;; File: "genfun2.scm"

;;-----------------------------------------------------------------------------

(define-type generic-function
  id: C158D90E-75CF-4F45-B7CF-EF7B9459D630
  macros:
  name
  methods
)

(define-macro (define-generic pattern)
  (let ((name (car pattern))
        (params (cdr pattern)))
    `(define ,name
       (make-generic-function
        ',name
        (make-table
         init: (lambda args
                 (error "no method for call"
                        (cons ',name (map ##inverse-eval args)))))))))

(define-macro (define-method pattern . body)
  (let ((name (car pattern))
        (params (map car (cdr pattern)))
        (type-ids (map cadr (cdr pattern))))
    `(table-set! (generic-function-methods ,name)
                 ',(list->vector type-ids)
                 (lambda ,params , at body))))

(define (type-identifier obj)
  (cond ((number? obj)    'number)
        ((string? obj)    'string)
        ((symbol? obj)    'symbol)
        ((boolean? obj)   'boolean)
        ((null? obj)      'null)
        ((pair? obj)      'pair)
        ((vector? obj)    'vector)
        ((procedure? obj) 'procedure)
        (else             'other)))

(current-exception-handler
 (let ((old-exception-handler (current-exception-handler)))
   (lambda (e)
     (if (nonprocedure-operator-exception? e)
         (let ((operator (nonprocedure-operator-exception-operator e))
               (arguments (nonprocedure-operator-exception-arguments e)))
           (if (generic-function? operator)
               (apply (table-ref (generic-function-methods operator)
                                 (list->vector (map type-identifier arguments)))
                      arguments)
               (old-exception-handler e)))
         (old-exception-handler e)))))

;;-----------------------------------------------------------------------------

;; Tests.

(define-generic (add x y))

(define-method (add (x number) (y number))
  (+ x y))

(define-method (add (x string) (y string))
  (string-append x y))

(define-method (add (x string) (y number))
  (string-append x (number->string y)))

(define-method (add (x number) (y string))
  (string-append (number->string x) y))

(pp (table->list (generic-function-methods add)))

(pp (add 11 22))
(pp (add "foo" "bar"))
(pp (add "foo" 99))
(pp (add 99 "foo"))
(pp (add #t #f))

;; output:
;;
;; ((#(string number) . #<procedure #2>)
;;  (#(string string) . #<procedure #3>)
;;  (#(number string) . #<procedure #4>)
;;  (#(number number) . #<procedure #5>))
;; 33
;; "foobar"
;; "foo99"
;; "99foo"
;; *** ERROR IN "genfun2.scm"@79.5 -- no method for call (add #t #f)

;;-----------------------------------------------------------------------------




More information about the Gambit-list mailing list