source: project/release/4/operations/operations.scm @ 12312

Last change on this file since 12312 was 12312, checked in by felix winkelmann, 12 years ago

ported to chicken-4

File size: 2.5 KB
Line 
1;;;; operations.scm
2
3
4(module operations
5
6    ((object make-object)
7     (operation get-handler)
8     define-predicate
9     define-operation
10     define-settable-operation
11     join
12     operation?)
13
14  (import scheme chicken lolevel srfi-1)
15
16(define-syntax object
17  (syntax-rules ()
18    ((_) (object #f))
19    ((_ default methods ...)
20     (make-object 
21      default 
22      (lambda (op)
23        (expand-methods op methods ...) ) ) ) ) )
24
25(define-syntax expand-methods
26  (syntax-rules ()
27    ((_ op) #f)
28    ((_ op ((proc . llist) body ...) . more)
29     (if (eq? op proc)
30         (lambda llist body ...)
31         (expand-methods op . more) ) ) ) )
32
33(define-syntax operation
34  (syntax-rules ()
35    ((_) (operation #f))
36    ((_ default methods ...)
37     (letrec ((opr (object
38                    (lambda (self . args)
39                      (let* ((handler (get-handler self))
40                             (method (and handler (handler opr)))
41                             (defaultm default))
42                        (cond (method (apply method self args))
43                              (defaultm (apply defaultm self args))
44                              (else (error "operation not handled by object" self)))))
45                    ((operation? self) #t)
46                    methods ...)))
47       opr) ) ) )
48
49(define-syntax define-predicate
50  (syntax-rules ()
51    ((_ name) (define-operation (name x) #f)) ) )
52
53(define-syntax define-operation
54  (syntax-rules ()
55    ((_ (name . llist))
56     (define name (operation #f)) )
57    ((_ (name . llist) x1 body ...)
58     (define name (operation (lambda llist x1 body ...)) ) )
59    ((_ name)
60     (define-operation (name) (operation #f)) ) ) )
61
62(define-syntax define-settable-operation
63  (syntax-rules ()
64    ((_ (name . args))
65     (define-settable-operation name) )
66    ((_ (name . args) x1 body ...)
67     (define name
68       (let ((the-setter (operation #f)))
69         (operation (lambda args body ...)
70           ((setter self) the-setter) ) ) ) )
71    ((_ name)
72     (define name
73       (let ((the-setter (operation #f)))
74         (operation #f ((setter self) the-setter)))))))
75
76(define-record t-object handler)
77
78(define (make-object default handler)
79  (let ((o (make-t-object handler)))
80    (if (procedure? default)
81        (extend-procedure default o) 
82        o) ) )
83
84(define (get-handler x)
85  (cond ((t-object? x) (t-object-handler x))
86        ((procedure? x) 
87         (let ((data (procedure-data x)))
88           (and data (t-object-handler data)) ) )
89        (else #f) ) )
90
91(define (join . objects)
92  (make-t-object
93   (lambda (op)
94     (any (lambda (o) ((get-handler o) op)) objects) ) ) )
95
96(define-predicate operation?)
97
98(set! ##sys#setter (let ((old setter)) (operation old)))
99(set! setter ##sys#setter)
100
101)
Note: See TracBrowser for help on using the repository browser.