source: project/release/4/ugarit/trunk/backend-devtools.scm @ 25521

Last change on this file since 25521 was 20740, checked in by Alaric Snell-Pym, 11 years ago

ugarit: Initial support for out-of-process backends (not yet well tested...)

File size: 4.3 KB
Line 
1 (define (backend-nullwrap be)
2   (make-storage
3      (storage-max-block-size be)
4      (storage-writable? be)
5      (storage-unlinkable? be)
6      (lambda (key data type) ; put!
7         ((storage-put! be) key data type))
8      (lambda (key) ; exists?
9         ((storage-exists? be) key))
10      (lambda (key) ; get
11         ((storage-get be) key))
12      (lambda (key) ; link!
13         ((storage-link! be) key))
14      (lambda (key) ; unlink!
15         ((storage-unlink! be) key))
16      (lambda (tag key) ; set-tag!
17         ((storage-set-tag! be) tag key))
18      (lambda (tag) ; tag
19         ((storage-tag be) tag))
20      (lambda () ; all-tags
21         ((storage-all-tags be)))
22      (lambda (tag) ; remove-tag!
23         ((storage-remove-tag! be) tag))
24      (lambda (tag) ; lock-tag!
25         ((storage-lock-tag! be) tag))
26      (lambda (tag) ; tag-locked?
27         ((storage-tag-locked? be) tag))
28      (lambda (tag) ; unlock-tag!
29         ((storage-unlock-tag! be) tag))
30      (lambda () ; close!
31         ((storage-close! be)))))
32
33(define (backend-limit-block-size be max-block-size)
34   (make-storage
35      (min max-block-size (storage-max-block-size be))
36      (storage-writable? be)
37      (storage-unlinkable? be)
38      (lambda (key data type) ; put!
39         ((storage-put! be) key data type))
40      (lambda (key) ; exists?
41         ((storage-exists? be) key))
42      (lambda (key) ; get
43         ((storage-get be) key))
44      (lambda (key) ; link!
45         ((storage-link! be) key))
46      (lambda (key) ; unlink!
47         ((storage-unlink! be) key))
48      (lambda (tag key) ; set-tag!
49         ((storage-set-tag! be) tag key))
50      (lambda (tag) ; tag
51         ((storage-tag be) tag))
52      (lambda () ; all-tags
53         ((storage-all-tags be)))
54      (lambda (tag) ; remove-tag!
55         ((storage-remove-tag! be) tag))
56      (lambda (tag) ; lock-tag!
57         ((storage-lock-tag! be) tag))
58      (lambda (tag) ; tag-locked?
59         ((storage-tag-locked? be) tag))
60      (lambda (tag) ; unlock-tag!
61         ((storage-unlock-tag! be) tag))
62      (lambda () ; close!
63         ((storage-close! be)))))
64
65(define (backend-debug be name)
66   (make-storage
67      (storage-max-block-size be)
68      (storage-writable? be)
69      (storage-unlinkable? be)
70      (lambda (key data type) ; put!
71         (begin
72            (printf "~A: (put! ~A ~A ~A)\n" name key data type)
73            ((storage-put! be) key data type)))
74      (lambda (key) ; exists?
75         (let ((result ((storage-exists? be) key)))
76            (begin
77               (printf "~A: (exists? ~A) = ~A\n" name key result)
78               result)))
79      (lambda (key) ; get
80         (let ((result ((storage-get be) key)))
81            (begin
82               (printf "~A: (get ~A) = ~A\n" name key result)
83               result)))
84      (lambda (key) ; link!
85         (begin
86            (printf "~A: (link! ~A)\n" name key)
87            ((storage-link! be) key)))
88      (lambda (key) ; unlink!
89         (let ((result ((storage-unlink! be) key)))
90            (begin
91               (printf "~A: (unlink! ~A) = ~A\n" name key result)
92               result)))
93      (lambda (tag key) ; set-tag!
94         (begin
95            (printf "~A: (set-tag! ~A ~A)\n" name tag key)
96            ((storage-set-tag! be) tag key)))
97      (lambda (tag) ; tag
98         (let ((result ((storage-tag be) tag)))
99            (begin
100               (printf "~A: (tag ~A) = ~A\n" name tag result)
101               result)))
102      (lambda () ; all-tags
103         (let ((result ((storage-all-tags be))))
104            (begin
105               (printf "~A: (all-tags) = ~A\n" name result)
106               result)))
107      (lambda (tag) ; remove-tag!
108         (begin
109            (printf "~A: (remove-tag! ~A)\n" name tag)
110            ((storage-remove-tag! be) tag)))
111      (lambda (tag) ; lock-tag!
112         (begin
113            (printf "~A: (lock-tag! ~A)\n" name tag)
114            ((storage-lock-tag! be) tag)))
115      (lambda (tag) ; tag-locked?
116         (let ((result ((storage-tag-locked? be) tag)))
117            (begin
118               (printf "~A: (tag-locked? ~A) = ~A\n" name tag result)
119               result)))
120      (lambda (tag) ; unlock-tag!
121         (begin
122            (printf "~A: (lock-tag! ~A)\n" name tag)
123            ((storage-unlock-tag! be) tag)))
124      (lambda () ; close!
125         (begin
126            (printf "~A: (close!)\n" name)
127            ((storage-close! be))))))
Note: See TracBrowser for help on using the repository browser.