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

Last change on this file since 14655 was 14655, checked in by felix winkelmann, 11 years ago

operations for r4

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