-
Notifications
You must be signed in to change notification settings - Fork 108
/
Absyn-Serial.ML
173 lines (147 loc) · 6.69 KB
/
Absyn-Serial.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
(*
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
*
* SPDX-License-Identifier: BSD-2-Clause
*)
structure Absyn_Serial =
struct
open Absyn
datatype serial = Nm of string * serial list | Q of string
fun opt_serial f (SOME v) = Nm ("SOME", [f v])
| opt_serial f NONE = Nm ("NONE", [])
fun list_serial f xs = Nm ("", map f xs)
fun pair_serial nm f g (x, y) = Nm (nm, [f x, g y])
fun b2s true = "true"
| b2s false = "false"
fun ty_serial f (Signed ity) = Nm ("Signed", [Q (inttyname ity)])
| ty_serial f (Unsigned ity) = Nm ("Unsigned", [Q (inttyname ity)])
| ty_serial f Bool = Nm ("Bool", [])
| ty_serial f PlainChar = Nm ("PlainChar", [])
| ty_serial f (StructTy s) = Nm ("StructTy", [Q s])
| ty_serial f (EnumTy so) = Nm ("EnumTy", [opt_serial Q so])
| ty_serial f (Ptr ty) = Nm ("Ptr", [ty_serial f ty])
| ty_serial f (Array (ty, co)) = Nm ("Array",
[ty_serial f ty, opt_serial f co])
| ty_serial f (Bitfield (b, c)) = Nm ("Bitfield", [Q (b2s b), f c])
| ty_serial f (Ident s) = Nm ("Ident", [Q s])
| ty_serial f (Function (ty, xs)) = Nm ("Function", [ty_serial f ty,
list_serial (ty_serial f) xs])
| ty_serial f Void = Nm ("Void", [])
val int_ctype_serial = ty_serial (fn i => Q (Int.toString i))
fun radix_string (StringCvt.BIN) = "BIN"
| radix_string (StringCvt.OCT) = "OCT"
| radix_string (StringCvt.DEC) = "DEC"
| radix_string (StringCvt.HEX) = "HEX"
fun literal_serial (STRING_LIT s) = Q s
| literal_serial (NUMCONST dets) = Nm ("NUMCONST",
[Q (IntInf.toString (#value dets)), Q (#suffix dets),
Q (radix_string (#base dets))])
fun vi_serial vi = opt_serial (fn (ty, _) => int_ctype_serial ty) (! vi)
fun expr_serial e = let
in
Nm (expr_string e,
case enode e of
BinOp (t, e, e2) => [Q (binopname t), expr_serial e, expr_serial e2]
| UnOp (t, e) => [Q (unopname t), expr_serial e]
| CondExp (e1, e2, e3) => map expr_serial [e1, e2, e3]
| Constant nc => [literal_serial (node nc)]
| Var (_, vi) => [vi_serial vi]
| StructDot (e, s) => [expr_serial e, Q s]
| ArrayDeref (e1, e2) => map expr_serial [e1, e2]
| Deref e => [expr_serial e]
| TypeCast (t, e) => [ty_serial expr_serial (node t), expr_serial e]
| Sizeof e => [expr_serial e]
| SizeofTy t => [ty_serial expr_serial (node t)]
| EFnCall (e, es) => map expr_serial (e :: es)
| CompLiteral (ty, xs) => [ty_serial expr_serial ty,
list_serial (pair_serial "" (list_serial desig_serial) init_serial) xs]
| Arbitrary t => [ty_serial expr_serial t]
| MKBOOL e => [expr_serial e]
| _ => [Q "[whoa! Unknown expr type]"]
)
end
and init_serial (InitE e) = Nm ("InitE", [expr_serial e])
| init_serial (InitList xs) = Nm ("InitList",
map (pair_serial "" (list_serial desig_serial) init_serial) xs)
and desig_serial (DesignE e) = Nm ("DesignE", [expr_serial e])
| desig_serial (DesignFld s) = Nm ("DesignFld", [Q s])
val expr_ctype_serial = ty_serial expr_serial
val varspec_serial = pair_serial "VarSpec" expr_ctype_serial (Q o node)
fun gcc_att_serial (GCC_AttribID s) = Nm ("GCC_AttribID", [Q s])
| gcc_att_serial (GCC_AttribFn (s, xs)) = Nm ("GCC_AttribFn",
[Q s, list_serial expr_serial xs])
| gcc_att_serial (OWNED_BY s) = Nm ("OWNED_BY", [Q s])
fun fnspec_serial (fnspec s) = Nm ("fnspec", [Q (node s)])
| fnspec_serial (relspec s) = Nm ("relspec", [Q (node s)])
| fnspec_serial (fn_modifies ss) = Nm ("fn_modifies", map Q ss)
| fnspec_serial didnt_translate = Nm ("DONT_TRANSLATE", [])
| fnspec_serial (gcc_attribs atts)
= Nm ("gcc_attribs", map gcc_att_serial atts)
fun storage_serial SC_EXTERN = Q "SC_EXTERN"
| storage_serial SC_STATIC = Q "SC_STATIC"
| storage_serial SC_AUTO = Q "SC_AUTO"
| storage_serial SC_REGISTER = Q "SC_REGISTER"
| storage_serial SC_THRD_LOCAL = Q "SC_THRD_LOCAL"
fun decl_serial (VarDecl (ty, s, cls, init, atts))
= Nm ("VarDecl", [varspec_serial (ty, s),
list_serial storage_serial cls,
opt_serial init_serial init, list_serial gcc_att_serial atts])
| decl_serial (StructDecl (s, xs)) = Nm ("StructDecl", [Q (node s),
list_serial varspec_serial xs])
| decl_serial (TypeDecl xs) = Nm ("TypeDecl", map varspec_serial xs)
| decl_serial (ExtFnDecl dets) = Nm ("ExtFnDecl",
[varspec_serial (#rettype dets, #name dets),
list_serial (pair_serial "VarSpecO" expr_ctype_serial
(opt_serial Q)) (#params dets),
list_serial fnspec_serial (#specs dets)])
| decl_serial (EnumDecl (so, xs)) = Nm ("EnumDecl",
[opt_serial Q (node so), list_serial (pair_serial "EnumElt" (Q o node)
(opt_serial expr_serial)) xs])
fun stmt_serial s = let
fun os2s (SOME s) = "Some (" ^ s ^ ")"
| os2s NONE = "None"
fun asm_serial1 (so, s, e) = Nm ("A1", [opt_serial Q so, Q s, expr_serial e])
fun asm_serial2 (b : asmblock) = Nm ("A2", [Q (#head b),
Nm ("M1", map asm_serial1 (#mod1 b)),
Nm ("M2", map asm_serial1 (#mod2 b)),
Nm ("M3", map Q (#mod3 b))])
fun sw_serial (eos, bis) = Nm ("Sw", [list_serial (opt_serial expr_serial) eos,
list_serial bi_serial bis])
in
Nm (stmt_type s,
case snode s of
Assign (e, e2) => map expr_serial [e, e2]
| AssignFnCall (lv, fnm, args) => opt_serial expr_serial lv
:: map expr_serial (fnm :: args)
| EmbFnCall (lv, fnm, args) => map expr_serial (lv :: fnm :: args)
| Block bis => map bi_serial bis
| Chaos e => [expr_serial e]
| While (e, s, stmt) => [expr_serial e, opt_serial Q (Option.map node s),
stmt_serial stmt]
| Trap (BreakT, stmt) => [Q "Break", stmt_serial stmt]
| Trap (ContinueT, stmt) => [Q "Continue", stmt_serial stmt]
| Return e => [opt_serial expr_serial e]
| ReturnFnCall (e, args) => map expr_serial (e :: args)
| Break => []
| Continue => []
| IfStmt (e, lhs, rhs) => [expr_serial e, stmt_serial lhs, stmt_serial rhs]
| Switch (e, sws) => expr_serial e :: map sw_serial sws
| EmptyStmt => []
| Auxupd s => [Q s]
| Spec ((a, b), stmts, c) => [Q a, Q b, Q c] @ map stmt_serial stmts
| AsmStmt dets => [Q (b2s (#volatilep dets)), asm_serial2 (#asmblock dets)]
| LocalInit e => [expr_serial e]
| _ => [Q "[whoa! Unknown stmt type]"]
)
end
and bi_serial (Absyn.BI_Decl d) = decl_serial (node d)
| bi_serial (Absyn.BI_Stmt s) = stmt_serial s
fun line_ind 0 s = s
| line_ind i s = " " ^ line_ind (i - 1) s
fun lines_serial_ind i (Nm ("", [])) = [line_ind i "[],"]
| lines_serial_ind i (Nm (s, [])) = [line_ind i (s ^ ",")]
| lines_serial_ind i (Nm (s, ts)) = [line_ind i (s ^ " [")]
@ List.concat (map (lines_serial_ind (i + 1)) ts) @ [line_ind i ("],")]
| lines_serial_ind i (Q s) = [line_ind i ("\"" ^ s ^ "\"")]
fun lines_serial ser = lines_serial_ind 0 ser
end;