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

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

Save.

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