| Sunnan 2004-03-27, 12:25 am |
| Here's what I came up with:
(define-syntax define-dispatch-wrappers
(lambda (x)
(define gen-def
(lambda (template-id number spot)
(datum->syntax-object
template-id
(let ((number (syntax-object->datum number))
(spot (syntax-object->datum spot)))
(cond ((eq? number -1) `(lambda (x) (x ',spot)))
((eq? number 0) `(lambda (x) ((x ',spot))))
((eq? number 1) `(lambda (x a) ((x ',spot) a)))
((eq? number 2) `(lambda (x a b) ((x ',spot) a b)))
(else `(lambda (x . args) (apply (x ',spot) args))))))))
(syntax-case x ()
((_ num e)
(with-syntax
((definition (gen-def (syntax e) (syntax num) (syntax e))))
(syntax (define e definition))))
((_ num e1 e2 ...)
(syntax (begin
(_ num e1)
(_ num e2 ...)))))))
;; And this will automatically generate functional wrappers around the
;; closure. Change it to "define-inline e definition" if your scheme
;; supports it to avoid any performance hit.
;; example code:
(define trallpop
((lambda ()
(define name 'poliskonstapel)
(define (hello)
(display "a trally hello\n"))
(define (me-too)
(display "me, too\n"))
(define (really me)
(display "this is nice ")
(display me)
(newline))
(define (dispatch m)
(case m
((name) name)
((hello) hello)
((me-too) me-too)
((really) really)))
dispatch)))
(display (trallpop 'name))
(newline)
((trallpop 'hello))
((trallpop 'really) "jordgubbe")
(define-dispatch-wrappers -1 name)
(define-dispatch-wrappers 0 hello me-too)
(define-dispatch-wrappers 1 really)
; the number is how many arguments. use 'inf or any other non-numeric
; for the apply-version. the apply version has a performance hit.
(display (name trallpop))
(newline)
(hello trallpop)
(me-too trallpop)
(really trallpop "smultron")
;; I also did a version of the -1 variant that also prepends
;; "get-". This uses gen-id from Dybvig's book, The Scheme Programming
;; Language:
(define-syntax define-dispatch-getters
(lambda (x)
(define gen-id
(lambda (template-id . args)
(datum->syntax-object template-id
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
(symbol->string
(syntax-object->datum x))))
args))))))
(syntax-case x ()
((_ e)
(with-syntax
((access (gen-id (syntax e) "get-" (syntax e))))
(syntax (define access (lambda (x) (x 'e))))))
((_ e1 e2 ...)
(syntax (begin
(_ e1)
(_ e2 ...)))))))
;; example usage:
(define-dispatch-getters name)
(display (get-name trallpop))
(newline)
;;;; And if I decide to use tinyclos for a project, I'll probably do
;;;; something similar to avoid writing those boring getters.
;;;; Feel free to use this code as much as you like. All rights reversed.
http://creativecommons.org/licenses/publicdomain/ <-- this is it girls and boys
that goes for define-dispatch-wrappers, at least. as noted earlier,
the function gen-id (used in define-dispatch-getters) was from
Dybvig's book. (Originally I used something embarrassing with
string-concatenate from SRFI-13). So as for licenses and other dirty
stuff for that particular part of define-dispatch-getters, you are on
your own.
Notes:
Some schemes will make their error messages a bit more confusing since
they will emit weird symbol names instead of the automatically
generated function names.
Works with mzscheme and chicken, hopefully with some others as
well. Uses syntax-case.
One love, Sunnan
|