mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 22:29:16 +02:00
df150c362d
Debating adding concept of more "specific" methods based on record inheritence. Lots of room for optimization.
79 lines
2.6 KiB
Scheme
79 lines
2.6 KiB
Scheme
|
|
(define-syntax define-generic
|
|
(syntax-rules ()
|
|
((define-generic name)
|
|
(define name (make-generic 'name)))))
|
|
|
|
'(define-syntax define-method
|
|
(syntax-rules ()
|
|
((define-method (name (param type) ...) . body)
|
|
(generic-add! name
|
|
(list type ...)
|
|
(lambda (next param ...)
|
|
(let-syntax ((call))
|
|
. body))))))
|
|
|
|
(define-syntax define-method
|
|
(er-macro-transformer
|
|
(lambda (e r c)
|
|
(let ((name (caadr e))
|
|
(params (cdadr e))
|
|
(body (cddr e)))
|
|
`(,(r 'generic-add!) ,name
|
|
(,(r 'list) ,@(map cadr params))
|
|
(,(r 'lambda) (next ,@(map car params))
|
|
(,(r 'let-syntax) ((call-next-method
|
|
(,(r 'syntax-rules) ()
|
|
((_) (next)))))
|
|
,@body)))))))
|
|
|
|
(define (no-applicable-method-error name args)
|
|
(error "no applicable method" name args))
|
|
|
|
(define (satisfied? preds args)
|
|
(cond ((null? preds) (null? args))
|
|
((null? args) #f)
|
|
(((car preds) (car args)) (satisfied? (cdr preds) (cdr args)))
|
|
(else #f)))
|
|
|
|
(define add-method-tag (list 'add-method-tag))
|
|
|
|
(define (make-generic name)
|
|
(let ((name name)
|
|
(methods (make-vector 6 '())))
|
|
(vector-set! methods
|
|
3
|
|
(list (cons (list (lambda (x) (eq? x add-method-tag))
|
|
(lambda (x) (list? x))
|
|
procedure?)
|
|
(lambda (next t p f)
|
|
(set! methods (insert-method! methods p f))))))
|
|
(lambda args
|
|
(let ((len (length args)))
|
|
(cond
|
|
((>= len (vector-length methods))
|
|
(no-applicable-method-error name args))
|
|
(else
|
|
(let lp ((ls (vector-ref methods len)))
|
|
(cond
|
|
((null? ls)
|
|
(no-applicable-method-error name args))
|
|
((satisfied? (car (car ls)) args)
|
|
(apply (cdr (car ls)) (lambda () (lp (cdr ls))) args))
|
|
(else
|
|
(lp (cdr ls)))))))))))
|
|
|
|
(define (insert-method! vec preds f)
|
|
(let ((vlen (vector-length vec))
|
|
(plen (length preds)))
|
|
(let ((res (if (>= plen vlen)
|
|
(let ((r (make-vector (+ vlen 1) '())))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i vlen) r)
|
|
(vector-set! r i (vector-ref vec i))))
|
|
vec)))
|
|
(vector-set! res plen (cons (cons preds f) (vector-ref res plen)))
|
|
res)))
|
|
|
|
(define (generic-add! g preds f)
|
|
(g add-method-tag preds f))
|