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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
;;; ----------------------------------------------------------------
;;; Text
;;; ----------------------------------------------------------------
(define (text-fns algdata suppress-reader?)
(let ((print+read
(cond ((algdata-enum? algdata)
(text-enum-fns algdata))
(else
(text-general-fns algdata)))))
(when suppress-reader?
(setf print+read (list (car print+read))))
print+read))
(define (text-enum-fns algdata)
(list
(**define '|showsPrec| '(|d| |x|)
(**case/con algdata (**var '|x|)
(lambda (con vars)
(declare (ignore vars))
(**showString (**string (con-string con))))))
(**define '|readsPrec| '(|d| |str|)
(**listcomp
(**var '|s|)
(list
(**gen '(tuple |tok| |rest|) (**lex (**var '|str|)))
(**gen '|s|
(**case (**var '|tok|)
`(,@(map (lambda (con)
(**alt/simple
(**pat (con-string con))
(**list (**tuple2 (**con/def con)
(**var '|rest|)))))
(algdata-constrs algdata))
,(**alt/simple (**pat '_) (**null))))))))))
;;; This has been hacked to split up the read function for large
;;; data types to avoid choking the lisp compiler.
(define (text-general-fns algdata)
(let ((split-fn-def? (> (algdata-n-constr algdata) 6))) ;; pretty arbitrary!
(list
(**define '|showsPrec| '(|d| |x|)
(**case/con algdata (**var '|x|)
(lambda (con vars)
(if (con-infix? con)
(show-infix con vars)
(show-prefix con vars)))))
(**define '|readsPrec| '(|d| |str|)
(**append/l
(map (lambda (con)
(cond ((con-infix? con)
(read-infix con))
(else
(read-prefix con split-fn-def?))))
(algdata-constrs algdata)))))))
(define (show-infix con vars)
(multiple-value-bind (p lp rp) (get-con-fixity con)
(**showParen
(**< (**Int p) (**var '|d|))
(**dot (**showsPrec (**int lp) (**var (car vars)))
(**showString
(**string (string-append " " (con-string con) " ")))
(**showsPrec (**int rp) (**var (cadr vars)))))))
(define (show-prefix con vars)
(**showParen
(**<= (**int 10) (**var '|d|))
(**dot/l (**showString (**string (con-string con)))
(show-fields vars))))
(define (show-fields vars)
(if (null? vars)
'()
`(,(**space) ,(**showsPrec (**int 10) (**var (car vars)))
,@(show-fields (cdr vars)))))
(define (read-infix con)
(multiple-value-bind (p lp rp) (get-con-fixity con)
(**let
(list
(**define '|readVal| '(|r|)
(**listcomp
(**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|))
(**var '|s2|))
(list
(**gen '(tuple |u| |s0|)
(**readsPrec (**int lp) (**var '|r|)))
(**gen `(tuple ,(con-string con) |s1|)
(**lex (**var '|s0|)))
(**gen '(tuple |v| |s2|)
(**readsprec (**int rp) (**var '|s1|)))))))
(**readParen (**< (**int p) (**var '|d|))
(**var '|readVal|) (**var '|str|)))))
(define (read-prefix con split?)
(let ((res (read-prefix-1 con)))
(if (not split?)
res
(dynamic-let ((*module-name* (def-module con)))
(dynamic-let ((*module* (table-entry *modules* *module-name*)))
(let* ((alg (con-alg con))
(fn (make-new-var
(string-append (symbol->string (def-name alg))
"/read-"
(remove-con-prefix
(symbol->string (def-name con))))))
(new-code (**app (**var/def fn) (**var '|str|) (**var '|d|)))
(def (**define fn '(|str| |d|) res)))
(setf (module-decls *module*) (cons def (module-decls *module*)))
new-code))))))
(define (read-prefix-1 con)
(let* ((arity (con-arity con))
(vars (temp-vars "x" arity))
(svars (cons '|rest| (temp-vars "s" arity))))
(**let
(list
(**define '|readVal| '(|r|)
(**listcomp
(**tuple2 (**app/l (**con/def con) (map (function **var) vars))
(**var (car (reverse svars))))
(cons
(**gen `(tuple ,(con-string con) |rest|)
(**lex (**var '|r|)))
(read-fields vars svars (cdr svars))))))
(**readParen (**< (**int 9) (**var '|d|))
(**var '|readVal|) (**var '|str|)))))
(define (read-fields vars s0 s1)
(if (null? vars)
'()
(cons
(**gen `(tuple ,(car vars) ,(car s1))
(**readsprec (**int 10) (**var (car s0))))
(read-fields (cdr vars) (cdr s0) (cdr s1)))))
;;; ----------------------------------------------------------------
;;; Binary
;;; ----------------------------------------------------------------
(define (binary-fns algdata)
(let ((res
(cond ((algdata-enum? algdata)
(binary-enum-fns algdata))
((algdata-tuple? algdata)
(binary-tuple-fns algdata))
(else
(binary-general-fns algdata)))))
; (dolist (x res)
; (fresh-line)
; (pprint x))
res))
(define (binary-enum-fns algdata)
(list
(**define '|showBin| '(|x| |b|)
(**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|)))
(**define '|readBin| '(|b|)
(**let
(list
(**define '(tuple |n| |b1|) '()
(**readBinSmallInt
(**var '|b|)
(**int (1- (algdata-n-constr algdata))))))
(**tuple2
(**case/int algdata (**var '|n|)
(lambda (con)
(**con/def con)))
(**var '|b1|))))))
(define (binary-tuple-fns algdata)
(let* ((con (tuple-con algdata))
(arity (con-arity con))
(vars (temp-vars "v" arity)))
(list
(**define '|showBin| `((,con ,@vars) |b|)
(show-binary-body vars '|b|))
(**define '|readBin| '(|b|)
(read-binary-body con)))))
(define (show-binary-body vars b)
(**foldr (lambda (new-term prev-terms)
(**showBin new-term prev-terms))
(map (function **var) vars)
(**var b)))
(define (read-binary-body con)
(let* ((arity (con-arity con))
(vars (temp-vars "v" arity))
(bvars (cons '|b| (temp-vars "b" arity))))
(**let
(map (lambda (v b nb)
(**define `(tuple ,v ,nb) '()
(**readBin (**var b))))
vars bvars (cdr bvars))
(**tuple2
(**app/l (**con/def con)
(map (function **var) vars))
(**var (car (reverse bvars)))))))
(define (binary-general-fns algdata)
(list
(**define '|showBin| '(|x| |b|)
(**showBinInt
(**con-number (**var '|x|) algdata)
(**case/con algdata (**var '|x|)
(lambda (con vars)
(declare (ignore con))
(show-binary-body vars '|b|)))))
(**define '|readBin| '(|bin|)
(**let
(list
(**define '(tuple |i| |b|) '()
(**readBinSmallInt (**var '|bin|)
(**int (1- (algdata-n-constr algdata))))))
(**case/int algdata (**var '|i|) (function read-binary-body))))))
(define (get-con-fixity con)
(let ((fixity (con-fixity con)))
(if (not (eq? fixity '#f))
(let ((p (fixity-precedence fixity))
(a (fixity-associativity fixity)))
(values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p))))
(values 9 10 9))))
|
