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
|
open StdLabels
module Ast = struct
type 'a variable = { pos : 'a; name : string; index : 'a expression option }
[@@deriving eq, show]
and 'a expression =
| Integer of 'a * string
| Literal of 'a * string
| Ident of 'a variable
| BinaryOp of 'a * T.boperator * 'a expression * 'a expression
| Op of 'a * T.uoperator * 'a expression
| Function of 'a * T.function_ * 'a expression list
[@@deriving eq, show]
and 'a condition = 'a * 'a expression * 'a statement list
and 'a statement =
| If of {
loc : 'a;
then_ : 'a condition;
elifs : 'a condition list;
else_ : 'a statement list;
}
| Act of { loc : 'a; label : 'a expression; statements : 'a statement list }
| Declaration of ('a * 'a variable * T.assignation_operator * 'a expression)
| Expression of 'a expression
| Comment of 'a
| Call of 'a * T.keywords * 'a expression list
| Location of 'a * string
[@@deriving eq, show]
end
(** Default implementation for the expression *)
module Expression : S.Expression with type t' = S.pos Ast.expression = struct
type t = S.pos Ast.expression
type t' = t
let v : t -> t' * Report.t list = fun t -> (t, [])
let integer : S.pos -> string -> t = fun pos i -> Ast.Integer (pos, i)
let literal : S.pos -> string -> t = fun pos l -> Ast.Literal (pos, l)
let function_ : S.pos -> T.function_ -> t list -> t =
fun pos name args -> Ast.Function (pos, name, args)
let uoperator : S.pos -> T.uoperator -> t -> t =
fun pos op expression -> Ast.Op (pos, op, expression)
let boperator : S.pos -> T.boperator -> t -> t -> t =
fun pos op op1 op2 ->
let op1 = op1 and op2 = op2 in
Ast.BinaryOp (pos, op, op1, op2)
let ident : (S.pos, t) S.variable -> t =
fun { pos; name; index } ->
let index = Option.map (fun i -> i) index in
Ast.Ident { pos; name; index }
end
module Instruction :
S.Instruction
with type expression = Expression.t' * Report.t list
and type t' = S.pos Ast.statement = struct
type t = S.pos Ast.statement
type t' = t
let v : t -> t' * Report.t list = fun t -> (t, [])
type expression = Expression.t' * Report.t list
let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun pos name args _ ->
let args = List.map ~f:fst args in
Ast.Call (pos, name, args)
let location : S.pos -> string -> t S.repr =
fun loc label _ -> Ast.Location (loc, label)
let comment : S.pos -> t S.repr = fun pos _ -> Ast.Comment pos
let expression : expression -> t S.repr =
fun expr _ -> Ast.Expression (fst expr)
let if_ :
S.pos ->
(expression, t) S.clause ->
elifs:(expression, t) S.clause list ->
else_:(S.pos * t S.repr list) option ->
t S.repr =
fun pos predicate ~elifs ~else_ _ ->
let clause (pos, expr, repr) =
let repr = List.map ~f:(fun instr -> instr []) repr in
(pos, fst @@ expr, repr)
in
let elifs = List.map ~f:clause elifs
and else_ =
match else_ with
| None -> []
| Some (_, instructions) ->
List.map ~f:(fun instr -> instr []) instructions
in
Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
fun pos ~label statements _ ->
let label = fst label
and statements = List.map ~f:(fun instr -> instr []) statements in
Ast.Act { loc = pos; label; statements }
let assign :
S.pos ->
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
t S.repr =
fun pos_loc { pos; name; index } op expr _ ->
(*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
let index = Option.map fst index in
let expr = fst expr in
Ast.Declaration (pos_loc, { pos; name; index }, op, expr)
end
module Location = struct
type instruction = (Instruction.t' * Report.t list) S.repr
type t = S.pos * S.pos Ast.statement list
let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
fun pos block report ->
let report, block =
List.fold_left_map ~init:report block ~f:(fun report b ->
let v, report = b report in
(report, v))
in
((pos, block), report)
end
|
