/table-rw.arc

 1; taken from http://awwx.ws/table-rw3.arc with slight modifications
 2; - Mark Huetsch
 3
 4(load "lib/extend.arc")
 5(load "lib/scheme.arc")
 6(load "lib/util.arc")
 7(load "lib/skipwhite.arc")
 8
 9(def parse-table-items (port (o acc (table)))
10  (scheme.skip-whitespace port)
11  (if (is (peekc port) #\})
12       (do (readc port) acc)
13       (with (k (read port)
14              v (read port))
15         (= (acc k) v)
16         (parse-table-items port acc))))
17
18(extend-readtable #\{ parse-table-items)
19
20; need the errsafe on type tests because (type x) croaks on
21; non-Arc types
22
23(extend ac-literal (x) (errsafe:isa x 'table)
24  scheme-t)
25
26(def print-table (f x s)
27  (scheme.display "{" s)
28  (between (k v) x (scheme.display " " s)
29    (write k s)
30    (scheme.display " " s)
31    (write v s))
32  (scheme.display "}" s))
33 
34(def print-cdr (f x s)
35  (if (no x)
36       (scheme.display ")" s)
37      (errsafe:acons x)
38       (do (scheme.display " " s)
39           (print f (car x) s)
40         (print-cdr f (cdr x) s))
41       (do (scheme.display " . " s)
42           (print f x s)
43         (scheme.display ")" s))))
44
45(def print (f x s)
46  (if (errsafe:acons x)
47       (do (scheme.display "(" s)
48           (print f (car x) s)
49           (print-cdr f (cdr x) s))
50      (errsafe:isa x 'table)
51       (print-table f x s)
52       (f x s))
53  (unless (and (bound 'explicit-flush) explicit-flush) (scheme.flush-output s)))
54
55(def disp (x (o s (stdout)))
56  (print scheme.display x s))
57
58(def write (x (o s (stdout)))
59  (print scheme.write x s))