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

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

added print-object; bumped version to 0.3

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