-
Notifications
You must be signed in to change notification settings - Fork 0
/
tag-parser.ml
293 lines (259 loc) · 14.6 KB
/
tag-parser.ml
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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
#use "reader.ml";;
open Reader;;
type constant =
| Sexpr of sexpr
| Void
type expr =
| Const of constant
| Var of string
| If of expr * expr * expr
| Seq of expr list
| Set of expr * expr
| Def of expr * expr
| Or of expr list
| LambdaSimple of string list * expr
| LambdaOpt of string list * string * expr
| Applic of expr * expr list;;
let rec expr_eq e1 e2 =
match e1, e2 with
| Const Void, Const Void -> true
| Const (Sexpr s1), Const (Sexpr s2) -> sexpr_eq s1 s2
| Var v1, Var v2 -> String.equal v1 v2
| If (t1, th1, el1), If (t2, th2, el2) -> expr_eq t1 t2 &&
expr_eq th1 th2 &&
expr_eq el1 el2
| Seq l1, Seq l2
| Or l1, Or l2 -> List.for_all2 expr_eq l1 l2
| Set (var1, val1), Set (var2, val2)
| Def (var1, val1), Def (var2, val2) -> expr_eq var1 var2 &&
expr_eq val1 val2
| LambdaSimple (vars1, body1), LambdaSimple (vars2, body2) ->
List.for_all2 String.equal vars1 vars2 &&
expr_eq body1 body2
| LambdaOpt (vars1, var1, body1), LambdaOpt (vars2, var2, body2) ->
String.equal var1 var2 &&
List.for_all2 String.equal vars1 vars2 &&
expr_eq body1 body2
| Applic (e1, args1), Applic (e2, args2) ->
expr_eq e1 e2 &&
List.for_all2 expr_eq args1 args2
| _ -> false;;
exception X_syntax_error;;
module type TAG_PARSER = sig
val tag_parse_expression : sexpr -> expr
val tag_parse_expressions : sexpr list -> expr list
end;; (* signature TAG_PARSER *)
module Tag_Parser : TAG_PARSER = struct
let reserved_word_list =
["and"; "begin"; "cond"; "define"; "else"; "if"; "lambda"; "let"; "let*";
"letrec"; "or"; "quasiquote"; "quote"; "set!"; "unquote"; "unquote-splicing"];;
(* work on the tag parser starts here *)
let rec tag_parse sexpr =
match sexpr with
| Pair (Symbol "cond", cond) -> parseCond cond
| Pair (Symbol "and", args) -> parseAnd args
| TaggedSexpr (name, Pair (Symbol "quote", Pair (data, Nil))) -> Const (Sexpr (TaggedSexpr (name, data)))
| Pair (Symbol "if", Pair (test, Pair (dit, Nil))) -> If (tag_parse test, tag_parse dit, Const Void)
| Pair (Symbol "if", Pair (test, Pair (dit, Pair (dif, Nil)))) -> If (tag_parse test, tag_parse dit, tag_parse dif)
| Pair (Symbol "define", Pair (Pair (Symbol name, args), body)) -> tag_parse (Pair (Symbol "define", Pair (Symbol name, Pair (Pair (Symbol "lambda", Pair (args, body)), Nil))))
| Pair (Symbol "define", Pair (Symbol name, Pair (sexpr, Nil))) -> Def (tag_parse (Symbol name), tag_parse sexpr)
| Pair (Symbol "let", Pair (bindings , body)) -> tag_parse (Pair (Pair (Symbol "lambda", Pair (getArgs bindings, body)), getVals bindings))
| Pair (Symbol "let*", Pair (bindings, body)) -> tag_parse (parseLetStar bindings body)
| Pair (Symbol "letrec", Pair (bindings, body)) -> tag_parse (parseLetRec bindings body)
| Pair (Symbol "set!", Pair (Symbol sym, Pair (arg, Nil))) -> Set (tag_parse (Symbol sym), tag_parse arg)
| Pair (Symbol "begin", bodies) -> sequencesExpr bodies
| Pair (Symbol "or", args) -> parseOr args
| Pair (Symbol "quote", Pair (x, Nil)) -> Const (Sexpr x)
| Pair (Symbol "lambda", Pair (args, bodies)) -> parseLambda args bodies
| Pair (Symbol "quasiquote", Pair (x, Nil)) -> parseQuasiquote x
| Pair (exp1, rest) -> Applic (tag_parse exp1, List.map tag_parse (pairToList rest))
| Number _|Char _|Bool _|String _|TagRef _|TaggedSexpr _ -> Const (Sexpr sexpr)
| Symbol s ->
if List.mem s reserved_word_list
then raise X_syntax_error
else Var s
| _ -> Const Void
and parseAnd =
function
| Nil -> tag_parse (Bool true)
| Pair (x, Nil) -> tag_parse x
| Pair (x, nextArgs) -> If (tag_parse x, parseAnd nextArgs, tag_parse (Bool false))
| _ -> raise X_syntax_error
and parseCond =
function
(* Reader.read_sexpr
"(let ((value expr)
(f (lambda ()
expr_f)))
(if value
((f) value)))";; *)
| Pair (Pair (expr, Pair (Symbol "=>", Pair (expr_f, Nil))), Nil) -> tag_parse (Pair (Symbol "let",
Pair
(Pair (Pair (Symbol "value", Pair (expr, Nil)),
Pair
(Pair (Symbol "f",
Pair (Pair (Symbol "lambda", Pair (Nil, Pair (expr_f, Nil))),
Nil)),
Nil)),
Pair
(Pair (Symbol "if",
Pair (Symbol "value",
Pair (Pair (Pair (Symbol "f", Nil), Pair (Symbol "value", Nil)), Nil))),
Nil)))) (* case 2 if last *)
(* Reader.read_sexpr
"(let ((value expr)
(f (lambda ()
expr_f))
(rest (lambda ()
restCond)))
(if value
((f) value)
(rest)))";; *)
| Pair (Pair (expr, Pair (Symbol "=>", Pair (expr_f, Nil))), nextCond) -> tag_parse (Pair (Symbol "let",
Pair
(Pair (Pair (Symbol "value", Pair (expr, Nil)),
Pair
(Pair (Symbol "f",
Pair (Pair (Symbol "lambda", Pair (Nil, Pair (expr_f, Nil))),
Nil)),
Pair
(Pair (Symbol "rest",
Pair
(Pair (Symbol "lambda", Pair (Nil, Pair (Pair (Symbol "cond", nextCond), Nil))),
Nil)),
Nil))),
Pair
(Pair (Symbol "if",
Pair (Symbol "value",
Pair (Pair (Pair (Symbol "f", Nil), Pair (Symbol "value", Nil)),
Pair (Pair (Symbol "rest", Nil), Nil)))),
Nil)))) (* case 2 *)
| Pair (Pair (Symbol "else", then1), _) -> tag_parse (Pair (Symbol "begin", then1)) (* case 3 *)
| Pair (Pair (cond1, then1), Nil) -> tag_parse (Pair (Symbol "if" ,Pair (cond1, Pair (Pair (Symbol "begin", then1), Nil)))) (* case 1, last cond *)
| Pair (Pair (cond1, then1), nextCond) -> tag_parse (Pair (Symbol "if", Pair (cond1, Pair (Pair (Symbol "begin", then1), Pair (Pair (Symbol "cond", nextCond), Nil))))) (* case 1 rest *)
| _ -> raise X_syntax_error
and parseQuasiquote x =
match x with
| Pair (Symbol "unquote", Pair (exp, Nil)) -> tag_parse exp (* case 1 *)
| Pair (Symbol "unquote-splicing", Pair (_, Nil)) -> raise X_syntax_error (* case 2 *)
| Nil|Symbol _ -> tag_parse (Pair (Symbol "quote", Pair (x, Nil))) (* case 3 *)
(* DO NOT DELETE!!! *)
(* | Pair (Pair (Symbol "unquote-splicing", Pair (exp, Nil)), Nil) -> Applic (Var "append", [tag_parse exp; Const (Sexpr Nil)]) (* case 5a ????? *) *)
| Pair (Pair (Symbol "unquote-splicing", Pair (exp_a, Nil)), exp_b) -> Applic (Var "append", [tag_parse exp_a; tag_parse (Pair (Symbol "quasiquote", Pair (exp_b, Nil)))]) (* case 5a *)
| Pair (exp_a, Pair (Symbol "unquote-splicing", Pair (exp_b, Nil))) -> Applic (Var "cons", [tag_parse (Pair (Symbol "quasiquote", Pair (exp_a, Nil))); tag_parse exp_b]) (* case 5b *)
| Pair (exp_a, exp_b) -> Applic (Var "cons", [tag_parse (Pair (Symbol "quasiquote", Pair (exp_a, Nil))); tag_parse (Pair (Symbol "quasiquote", Pair (exp_b, Nil)))]) (* case 5c *)
(* | Vector lst -> Applic (Var "vector", List.map (fun x -> tag_parse (Pair (Symbol "quote", Pair (x, Nil)))) lst) (* case 4 *) *)
| Number _|Bool _|String _|Char _|TagRef _|TaggedSexpr _ -> tag_parse x (* the rest *)
and pairToList =
function
| Nil -> []
| Pair (left, right) -> left :: pairToList right
| _ -> raise X_syntax_error
and parseOr args =
match args with
| Nil -> tag_parse (Bool false)
| Pair (x, Nil) -> tag_parse x
| _ -> Or (List.map tag_parse (pairToList args))
and getArgs =
function
| Nil -> Nil
(* | Pair (Pair (arg, v), Nil) -> Pair (arg, Nil) *)
| Pair (Pair (arg, Pair (_, Nil)), bindings) -> Pair (arg, getArgs bindings)
| _ -> raise X_syntax_error
and getVals =
function
| Nil -> Nil
(* | Pair (Pair (arg, Pair (v, Nil)), Nil) -> Pair (v, Nil) *)
| Pair (Pair (_, Pair (v, Nil)), bindings) -> Pair (v, getVals bindings)
| _ -> raise X_syntax_error
and parseLetStar bindings body =
match bindings with
| Nil -> Pair (Symbol "let", Pair (bindings, body))
| Pair (Pair (arg, Pair (v, Nil)), Nil) -> Pair (Symbol "let", Pair (Pair (Pair (arg, Pair (v, Nil)), Nil), body))
| Pair (Pair (arg, Pair (v, Nil)), bindings) -> Pair (Symbol "let", Pair (Pair (Pair (arg, Pair (v, Nil)), Nil), Pair (parseLetStar bindings body, Nil)))
| _ -> raise X_syntax_error
and parseLetRec bindings body = Pair (Symbol "let", Pair (parseLetRecBindings bindings, parseLetRecBody bindings body))
and parseLetRecBindings =
function
| Nil -> Nil
(* | Pair (Pair (arg, Pair (v, Nil)), Nil) -> Pair (Pair (arg, Pair (Bool true, Nil)), Nil) *)
| Pair (Pair (arg, Pair (_, Nil)), bindings) -> Pair (Pair (arg, (Pair (Pair (Symbol "quote", Pair (Symbol "whatever", Nil)) , Nil))), parseLetRecBindings bindings)
| _ -> raise X_syntax_error
and parseLetRecBody bindings body =
match bindings with
| Nil -> body
(* | Pair (Pair (arg, Pair (v, Nil)), Nil) -> Pair (Pair (Symbol "set!", Pair (arg, Pair (v, Nil))), body) *)
| Pair (Pair (arg, Pair (v, Nil)), bindings) -> Pair (Pair (Symbol "set!", Pair (arg, Pair (v, Nil))), parseLetRecBody bindings body)
| _ -> raise X_syntax_error
and parseLambda args bodies =
if isSimpleLambda args
then parseLambdaSimple args bodies
else parseLambdaOpt args bodies
and isSimpleLambda =
function
| Nil -> true
| Pair (Symbol _, Symbol _) -> false
| Pair (Symbol _, x) -> isSimpleLambda x
| Symbol x -> false
| _ -> raise X_syntax_error
(* and sequencesImplicitExpr =
function
| Nil -> []
(* | Pair (hd, Pair (tl, Nil)) -> [tag_parse hd; tag_parse tl] (* not necessary??????? *) *)
| Pair (hd, tail) -> tag_parse hd :: sequencesImplicitExpr tail
| _-> raise X_syntax_error *)
and sequencesExpr bodies =
match bodies with
| Nil -> Const Void
| Pair (body, Nil) -> tag_parse body
(* | _ -> Seq (sequencesImplicitExpr bodies) *)
| _ -> Seq (List.map tag_parse (pairToList bodies))
and parseLambdaSimple args bodies =
match bodies with
| Nil -> raise X_syntax_error
| Pair (body, Nil) -> LambdaSimple (parseLambdaParams args pairToList, tag_parse body)
| _ -> LambdaSimple (parseLambdaParams args pairToList, sequencesExpr bodies)
and parseLambdaOpt args bodies =
match bodies with
| Nil -> raise X_syntax_error
| Pair (body, Nil) -> LambdaOpt ((List.rev (List.tl (List.rev (parseLambdaParams args pairToListOpt)))),
(List.hd (List.rev (parseLambdaParams args pairToListOpt))), (tag_parse body))
| _ -> LambdaOpt ((List.rev (List.tl (List.rev (parseLambdaParams args pairToListOpt)))),
(List.hd (List.rev (parseLambdaParams args pairToListOpt))), sequencesExpr bodies)
and parseLambdaParams params pairToListFunc =
(* let lst = pairToListFunc params in *)
List.map (fun param ->
match param with
| Symbol str ->
if List.mem str reserved_word_list
then raise X_syntax_error
else str
| _ -> raise X_syntax_error)
(duplicateCheck (pairToListFunc params))
and duplicateCheck lst =
let rec check =
function
| [] -> lst
| car :: cdr ->
if List.mem car cdr
then raise X_syntax_error
else check cdr
in
check lst
(* and duplicateCheck lst originalList =
if lst = []
then originalList
else
if List.mem (List.hd lst) (List.tl lst)
then raise X_syntax_error
else duplicateCheck (List.tl lst) originalList *)
and pairToListOpt =
function
| Pair (left, Pair (left2, right2)) -> left :: pairToListOpt (Pair (left2, right2))
| Pair (left, right) -> left :: [right]
| Symbol x -> [Symbol x]
| _ -> raise X_syntax_error
;;
let tag_parse_expression sexpr = tag_parse sexpr;;
let tag_parse_expressions sexprs = List.map tag_parse_expression sexprs;;
end;;