blob: fa1aec29cad309628054162e0d02cdf6c51729db (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
;;; (fff read) --- read an fff file into a scheme structure
;; (C) Case Duckworth <acdw@acdw.net>
(import (scheme base)
(scheme case-lambda)
(fff parse)
(srfi 1)
(utf8))
;;; Parameters
(define chunk-size
(make-parameter 2048))
(define ignore-comments?
(make-parameter #t))
(define base-environment
(make-parameter '(("true" . #t)
("false" . #f)
("null" . null))))
;;; Transforming parsed intermediate representation into fff
(define (comment? it)
(eq? 'comment (car it)))
(define (singleton it)
(if (pair? it)
(if (not (pair? (cdr it)))
#t
(and (eq? 'ref (cadr it))
(not (pair? (cddr it)))
'ref))
#f))
(define (resolve-ref obj env)
(let ((ref (cddr obj)))
(if (assoc ref env)
(cons (car obj)
(cdr (assoc ref env)))
(error "Reference doesn't exist: " ref env))))
(define (resolve-refs obj env)
;;; Resolve references in OBJ using ENV.
(let loop ((items (cdr obj))
(new-obj (list (car obj)))
(resolved-refs '()))
(if (null? items)
(values (reverse new-obj)
resolved-refs)
(let ((this (car items)))
(if (and (pair? (cdr this))
(eq? 'ref (cadr this)))
(loop (cdr items)
(cons (resolve-ref this env) new-obj)
(cons (cddr this) resolved-refs))
(loop (cdr items)
(cons this new-obj)
resolved-refs))))))
(define (maybe-vector obj)
(let loop ((items (cdr obj))
(type #f))
(cond
((comment? obj)
(cons 'comment
(apply string-append
(map (lambda (s)
(string-append s "\n"))
(cdr obj)))))
((and (null? items)
(eq? type 'object))
obj)
((and (null? items)
(eq? type 'vector))
(cons (car obj)
(list->vector (map cdr (cdr obj)))))
((not (pair? items))
obj)
(else
(loop (cdr items)
(if (caar items)
(if (eq? type 'vector)
(error "Item type mismatch" 'object type)
'object)
(if (eq? type 'object)
(error "Item type mismatch" 'vector type)
'vector)))))))
(define (%fff->scm fff env acc dupes)
(if (null? fff)
(map maybe-vector
(reverse
(filter
(lambda (x) (not (member (car x) dupes)))
acc)))
(let ((this (car fff))
(rest (cdr fff)))
(cond
((comment? this)
(if (ignore-comments?)
(%fff->scm (cdr fff) env acc dupes)
(%fff->scm rest env (cons this acc) dupes)))
((singleton this) =>
(lambda (x)
(%fff->scm rest
(cons this env)
(cons (if (eq? 'ref x)
(resolve-ref this (append env fff))
this)
acc)
(if (eq? 'ref x)
(cons (cddr this) dupes)
dupes))))
(else
(let-values (((resolved references)
(resolve-refs this (append env fff))))
(%fff->scm rest
(cons this env)
(cons resolved acc)
(append references dupes))))))))
(define fff->scm
(case-lambda
((fff)
(%fff->scm fff (base-environment) '() '()))
((fff env)
(%fff->scm fff env '() '()))))
;;; Reading fff
(define (read-port port)
(let loop ((next (read-string (chunk-size) port))
(blank? #f)
(acc '()))
(cond
((or (eof-object? next)
(and blank? (equal? next "")))
(close-input-port port)
(apply string-append (reverse acc)))
((equal? next "")
(loop (read-string (chunk-size) port)
#t
(cons next acc)))
(else
(loop (read-string (chunk-size) port)
blank?
(cons next acc))))))
(define (%read-fff port)
(or (fff->scm (parse-fff (read-port port)))
(error "Invalid fff" port)))
(define read-fff
(case-lambda
(()
(%read-fff (current-input-port)))
((port)
(%read-fff port))))
(define (read-fff-string str)
(call-with-port (open-input-string str) %read-fff))
|
