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
|
open StdLabels
module Expression = struct
type t = unit
type t' = unit
include Default.Expression (struct
type nonrec t = t
let default = ()
end)
let v : t -> t' * Report.t list = fun () -> ((), [])
end
module Instruction = struct
type expression = Expression.t' * Report.t list
type cause = Missing_else | Unchecked_path
type state = {
block_pos : S.pos;
has_gt : bool;
is_gt : bool;
pos : (cause * S.pos) option;
}
type t = state * Report.t list
type t' = state
(** For each instruction, return thoses two informations :
- the intruction contains at [gt]
- the last instruction is a [gt]
*)
let v : t -> t' * Report.t list = fun t -> t
let default =
{
block_pos = (Lexing.dummy_pos, Lexing.dummy_pos);
has_gt = false;
is_gt = false;
pos = None;
}
(** Call for an instruction like [GT] or [*CLR] *)
let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun pos f _ report ->
ignore pos;
match f with
| T.Goto | T.XGoto ->
({ block_pos = pos; has_gt = true; is_gt = true; pos = None }, report)
| T.Gosub ->
({ block_pos = pos; has_gt = false; is_gt = true; pos = None }, report)
| _ -> (default, report)
(** Label for a loop *)
let location : S.pos -> string -> t S.repr =
fun _ _ report -> (default, report)
(** Comment *)
let comment : S.pos -> t S.repr = fun _ report -> (default, report)
(** Raw expression *)
let expression : expression -> t S.repr = fun _ report -> (default, report)
(** The content of a block is very linear, I only need to check the last element *)
let check_block : S.pos -> t S.repr list -> t S.repr =
fun pos instructions report ->
let last_element =
List.fold_left instructions ~init:(default, report)
~f:(fun (t, report) instruction ->
let result, report = instruction report in
let has_gt = result.has_gt || t.has_gt in
let is_gt = result.is_gt || t.is_gt in
({ result with block_pos = pos; is_gt; has_gt }, report))
in
last_element
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 clause ~elifs ~else_ report ->
(* For each block, evaluate the instructions *)
let report, res, has_gt, is_gt =
List.fold_left ~init:(report, [], false, false) (clause :: elifs)
~f:(fun (report, acc, has_gt, is_gt) clause ->
let pos, _, instructions = clause in
let clause_t, report = check_block pos instructions report in
let has_gt = has_gt || clause_t.has_gt
and is_gt = is_gt || clause_t.is_gt in
(report, (clause_t, pos) :: acc, has_gt, is_gt))
in
let else_pos, else_block, report =
match else_ with
| Some (pos, instructions) ->
let block, report = check_block pos instructions report in
(pos, block, report)
| None -> (pos, default, report)
in
let has_gt = has_gt || else_block.has_gt
and is_gt = is_gt || else_block.is_gt in
let blocks = (else_block, else_pos) :: res in
(* Check if one of the clauses already holds a dead end*)
match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with
| Some (v, _) -> (v, report)
| None -> (
match (is_gt, has_gt) with
| _, true -> (
(* There is gt intruction in one of the branch, we need to checks
the others *)
match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with
| None ->
(* Every branch in the if is covered. It’s ok. *)
({ default with block_pos = pos; is_gt; has_gt }, report)
| Some (_, pos) ->
(* TODO check if [pos] is the whole block *)
let cause =
match else_ with None -> Missing_else | _ -> Unchecked_path
in
( { default with block_pos = pos; pos = Some (cause, pos) },
report ))
| _, _ -> ({ default with block_pos = pos; has_gt; is_gt }, report))
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
fun pos ~label expressions report ->
ignore label;
check_block pos expressions report
let assign :
S.pos ->
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
t S.repr =
fun _ _ _ _ report -> (default, report)
end
module Location = struct
type t = unit
type instruction = (Instruction.t' * Report.t list) S.repr
let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
fun _pos instructions report ->
( (),
List.fold_left instructions ~init:report ~f:(fun report instruction ->
let t, r = instruction [] in
let report = List.rev_append r report in
match (t.Instruction.is_gt, t.Instruction.pos) with
| false, Some (cause, value) ->
ignore cause;
if t.Instruction.block_pos != value then
match cause with
| Missing_else ->
Report.debug value "Possible dead end (no else fallback)"
:: report
| Unchecked_path ->
Report.warn value "Possible dead end (unmatched path)"
:: report
else report
| _ -> report) )
end
|
