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
open AST
open ASTUtils
let desugar_setter call fields rhs =
let loc = to_pos call and { desc = { name; params; args } } = call in
let () = assert (loc.version = V1) in
let here desc = add_pos_from loc desc in
match fields with
| [] ->
S_Call { name; args = rhs :: args; params; call_type = ST_Setter }
| _ ->
let temp = fresh_var "__setter_v1_temporary" in
let read =
let getter_call =
E_Call { name; args; params; call_type = ST_Getter } |> here
in
S_Decl (LDK_Var, LDI_Var temp, None, Some getter_call) |> here
in
let modify =
let temp_le = LE_Var temp |> here in
let lhs =
match fields with
| [ field ] -> LE_SetField (temp_le, field)
| _ -> LE_SetFields (temp_le, fields, [])
in
S_Assign (lhs |> here, rhs) |> here
in
let write =
let temp_e = E_Var temp |> here in
S_Call { name; args = temp_e :: args; params; call_type = ST_Setter }
|> here
in
S_Seq (s_then read modify, write)
let desugar_elided_parameter ldk lhs ty (call : call annotated) =
let bits_e =
match ty.desc with
| T_Bits (bits_e, []) -> bits_e
| _ ->
Error.fatal_from (to_pos call) CannotParse
in
let params = bits_e :: call.desc.params in
let rhs = E_Call { call.desc with params } |> add_pos_from call in
S_Decl (ldk, lhs, Some ty, Some rhs)
type lhs_field = identifier annotated
type lhs_access = {
base : identifier annotated;
index : expr option;
fields : lhs_field list; (** empty means no fields *)
slices : slice list annotated; (** empty means no slices*)
}
let desugar_lhs_access { base; index; fields; slices } =
let var = LE_Var base.desc |> add_pos_from base in
let with_index =
match index with
| None -> var
| Some idx -> LE_SetArray (var, idx) |> add_pos_from idx
in
let with_fields =
List.fold_left
(fun acc field -> LE_SetField (acc, field.desc) |> add_pos_from field)
with_index fields
in
let with_slices =
match slices.desc with
| [] -> with_fields
| _ -> LE_Slice (with_fields, slices.desc) |> add_pos_from slices
in
with_slices
let desugar_lhs_tuple laccess_opts =
let bases =
List.filter_map (Option.map (fun { base } -> base.desc)) laccess_opts.desc
in
match get_first_duplicate bases with
| Some dup -> Error.fatal_from (to_pos laccess_opts) (MultipleWrites dup)
| None ->
let desugar_one = function
| None -> LE_Discard |> add_pos_from laccess_opts
| Some laccess -> desugar_lhs_access laccess
in
LE_Destructuring (List.map desugar_one laccess_opts.desc)
|> add_pos_from laccess_opts
let desugar_lhs_fields_tuple base field_opts =
let fields = List.filter_map (Option.map (fun fld -> fld.desc)) field_opts in
match get_first_duplicate fields with
| Some dup ->
Error.fatal_from (to_pos base) (MultipleWrites (base.desc ^ "." ^ dup))
| None ->
let desugar_one = function
| None -> LE_Discard |> add_pos_from base
| Some fld ->
let var = LE_Var base.desc |> add_pos_from base in
LE_SetField (var, fld.desc) |> add_pos_from fld
in
LE_Destructuring (List.map desugar_one field_opts)
let desugar_case_stmt e0 cases otherwise =
let case_to_cond e0 case tail =
let { pattern; where; stmt } = case.desc in
let e_pattern = E_Pattern (e0, pattern) |> add_pos_from pattern in
let cond =
match where with
| None -> e_pattern
| Some e_where -> binop BAND e_pattern e_where
in
S_Cond (cond, stmt, tail) |> add_pos_from case
in
let cases_to_cond e0 cases =
List.fold_right (case_to_cond e0) cases otherwise
in
match e0.desc with
| E_Var _ -> (cases_to_cond e0 cases).desc
| _ ->
let x = fresh_var "__case__linearisation" in
let decl_x = S_Decl (LDK_Let, LDI_Var x, None, Some e0) in
S_Seq (decl_x |> add_pos_from e0, cases_to_cond (var_ x) cases)