73 lines
2.0 KiB
Scheme
73 lines
2.0 KiB
Scheme
(define-library (picrin protocol)
|
|
(import (scheme base)
|
|
(srfi 1))
|
|
|
|
(import (picrin class))
|
|
|
|
(define method-table
|
|
'())
|
|
|
|
(define (applicative? args types)
|
|
(cond
|
|
((and (null? args) (null? types))
|
|
#true)
|
|
((and (pair? args) (pair? types))
|
|
(and (instance? (car args) (car types)) (applicative? (cdr args) (cdr types))))
|
|
(else
|
|
#false)))
|
|
|
|
(define (find-generic generic)
|
|
(or (assq generic method-table)
|
|
(error "no method alist found")))
|
|
|
|
(define (find-method generic args)
|
|
(let ((methods (cdr (find-generic generic))))
|
|
(let ((m (filter (lambda (x) (applicative? args (cdr x))) methods)))
|
|
(if (null? m)
|
|
#f
|
|
(car (car m))))))
|
|
|
|
(define (add-generic generic)
|
|
(set! method-table (cons (cons generic '()) method-table)))
|
|
|
|
(define (add-method generic method types)
|
|
(let ((r (find-generic generic)))
|
|
(set-cdr! r (cons (cons method types) (cdr r)))))
|
|
|
|
(define (add-methods methods prototypes)
|
|
(for-each
|
|
(lambda (method prototype)
|
|
(add-method (car prototype) method (cdr prototype)))
|
|
methods
|
|
prototypes))
|
|
|
|
(define make-generic
|
|
(lambda ()
|
|
(letrec ((self (lambda args
|
|
(let ((m (find-method self args)))
|
|
(if m
|
|
(apply m args)
|
|
(error "method not found"))))))
|
|
(add-generic self)
|
|
self)))
|
|
|
|
(define-syntax define-protocol
|
|
(syntax-rules ()
|
|
((define-protocol (name type ...) (method arg ...) ...)
|
|
(begin
|
|
(define method
|
|
(make-generic))
|
|
...
|
|
(define name
|
|
(lambda (type ...)
|
|
(lambda methods
|
|
(add-methods methods (list (list method arg ...) ...)))))))))
|
|
|
|
(define-syntax define-instance
|
|
(syntax-rules ()
|
|
((define-instance (name arg ...) method ...)
|
|
((name arg ...) method ...))))
|
|
|
|
(export define-protocol
|
|
define-instance))
|