source: project/release/4/procedure-decoration/trunk/procedure-decoration.scm @ 16074

Last change on this file since 16074 was 16074, checked in by Kon Lovett, 11 years ago

Create from srfi-102

File size: 6.0 KB
Line 
1;;;; procedure-decoration.scm  -*- Hen -*-
2
3(module procedure-decoration
4
5  (;export
6    ;; Checked API
7    decorated-lambda?
8    lambda-decoration
9    decorate-lambda
10    ;;
11    make-procedure-decorator
12    procedure-decorator?
13    procedure-decorator-become?
14    procedure-decorator-getter-and-setter
15    decorated-procedure?
16    procedure-decoration
17    decorate-procedure
18    ;; Tagged API
19    make-procedure-extender
20    define-procedure-extender)
21
22  (import scheme
23          chicken
24          (only type-checks
25                check-procedure check-cardinal-fixnum
26                define-check+error-type))
27
28  (require-library type-checks)
29
30;;;
31
32;;
33
34(define (->boolean obj) (and obj #t))
35
36;;
37
38(define (##sys#update-lambda-decoration proc pred decr)
39  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
40  (##sys#decorate-lambda proc pred setter) )
41
42;;
43
44(define *lambda-decoration ##sys#lambda-decoration)
45
46(define *decorate-lambda ##sys#update-lambda-decoration)
47
48(define (*decorated-lambda? proc pred) (->boolean (##sys#lambda-decoration proc pred)))
49
50;;
51
52(define (check-procedure2 loc obj1 obj2)
53  (check-procedure loc obj1)
54  (check-procedure loc obj2) )
55
56(define (check-procedure3 loc obj1 obj2 obj3)
57  (check-procedure2 loc obj1 obj2)
58  (check-procedure loc obj3) )
59
60(define-check+error-type decorated-lambda *decorated-lambda?)
61
62;;
63
64(define (decorated-lambda? proc pred)
65  (check-procedure2 'decorated-lambda? proc pred)
66  (*decorated-lambda? proc pred) )
67
68(define (lambda-decoration proc pred)
69  (check-procedure2 'lambda-decoration proc pred)
70  (*lambda-decoration proc pred) )
71
72(define (decorate-lambda proc pred decr)
73  (check-procedure3 'decorate-lambda proc pred decr)
74  (*decorate-lambda proc pred decr) )
75
76;;;
77
78;;
79
80(define-record-type procedure-decorator
81  (*make-procedure-decorator pred intr decr getr bcmf)
82  procedure-decorator?
83  (bcmf procedure-decorator-become?)
84  (pred procedure-decorator-predicate)
85  (intr procedure-decorator-initializer)
86  (decr procedure-decorator-mutator)
87  (getr procedure-decorator-retriever) )
88
89;;
90
91(define-check+error-type procedure-decorator)
92
93;;
94
95(define (*procedure-decoration proc dctr)
96  (*lambda-decoration proc (procedure-decorator-predicate dctr)) )
97
98(define (*retrieve-procedure-decoration proc dctr args)
99  ((procedure-decorator-retriever dctr) (*procedure-decoration proc dctr) args) )
100
101(define (*procedure-become proc new) (##sys#become! `((,proc . ,new))) proc)
102
103(define (*decorate-procedure proc dctr args)
104  (let* ((pred (procedure-decorator-predicate dctr)))
105    (if (*decorated-lambda? proc pred)
106        (let ((decr (lambda (obj) ((procedure-decorator-mutator dctr) obj args))))
107          (*decorate-lambda proc pred decr) )
108        (let* ((intr (lambda (obj) ((procedure-decorator-initializer dctr) args)))
109               (new (*decorate-lambda proc pred intr)) )
110          (if (not (procedure-decorator-become? dctr)) new
111              (*procedure-become proc new) ) ) ) ) )
112
113(define ((*decorator-initializer decr) . args) (apply decr (void) args))
114
115(define ((*procedure-decorator-getter dctr) proc)  (*retrieve-procedure-decoration proc dctr '()))
116(define ((*procedure-decorator-setter dctr) proc val) (*decorate-procedure proc dctr (list val)))
117
118;;
119
120(define (make-procedure-decorator pred decr retr
121                                  #!key (initializer #f)
122                                        (replace? #f))
123  (check-procedure3 'make-procedure-decorator pred decr retr)
124  (when initializer (check-procedure 'make-procedure-decorator initializer))
125  (let ((intr (or initializer (*decorator-initializer initializer decr))))
126    (*make-procedure-decorator pred intr decr retr replace?) ) )
127
128(define (procedure-decorator-replace? dctr)
129  (check-procedure-decorator 'procedure-decorator-replace? dctr)
130  (procedure-decorator-become? dctr) )
131
132(define (procedure-decorator-getter-and-setter dctr)
133  (check-procedure-decorator 'procedure-decorator-getter-and-setter dctr)
134  (getter-with-setter (*procedure-decorator-getter dctr) (*procedure-decorator-setter dctr)) )
135
136;;
137
138(define (decorated-procedure? proc dctr)
139  (check-procedure 'decorated-procedure? proc)
140  (check-procedure-decorator 'decorated-procedure? dctr)
141  (*decorated-lambda? proc (procedure-decorator-predicate dctr)) )
142
143(define (procedure-decoration proc dctr . args)
144  (check-procedure 'procedure-decoration proc)
145  (check-procedure-decorator 'procedure-decoration dctr)
146  (*retrieve-procedure-decoration proc dctr args) )
147
148(define (decorate-procedure proc dctr . args)
149  (check-procedure 'decorate-procedure proc)
150  (check-procedure-decorator 'decorate-procedure dctr)
151  (*decorate-procedure proc dctr args) )
152
153;;;
154
155;; A simple procedure decorator
156
157(define (make-procedure-extender tag)
158  (make-procedure-decorator (lambda (obj) (and (pair? obj) (eq? tag (car obj))))
159                            (lambda (_ new) (cons tag new))
160                            cdr
161                            #:become? #t) )
162
163;; Define procedures for getting, setting, & testing a decorated procedure
164
165(define-for-syntax (procdecrname tag suff) (string->symbol (conc tag #\- suff)))
166
167(define-syntax define-procedure-extender
168  (er-macro-transformer
169    (lambda (frm rnm cmp)
170      (let ((_define (rnm 'define))
171            (_set! (rnm 'set!))
172            (_begin (rnm 'begin))
173            (_make-procedure-extender (rnm 'make-procedure-extender))
174            (_procedure-decorator-getter-and-setter (rnm 'procedure-decorator-getter-and-setter))
175            (_decorated-procedure? (rnm 'decorated-procedure?)) )
176      (let-optionals ?rest ((?getrname (procdecrname ?tag 'decoration))
177                            (?predname (procdecrname ?tag 'decorated?)))
178        (let ((?dctrname (procdecrname ?tag 'decorator)))
179          `(,_begin
180            (,_define ,?getrname)
181            (,_define ,?predname)
182            (,_define ,?dctrname)
183            (let ((dctr (,_make-procedure-extender ',?tag)))
184              (set! ,?dctrname dctr)
185              (set! ,?getrname (,_procedure-decorator-getter-and-setter dctr))
186              (set! ,?predname (cut ,_decorated-procedure? <> dctr)) ) ) ) ) ) ) ) )
187
188) ;module procedure-decoration
Note: See TracBrowser for help on using the repository browser.