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
|
open StdLabels
let identifier = "dead_end"
let description = "Check for dead end in the code"
let is_global = false
let active = ref false
type context = unit
let initialize = Fun.id
let finalize () = []
module Expression = struct
type t = unit
include Default.Expression (struct
type nonrec t = t
let default = ()
end)
let v : t -> t' = fun () -> ()
end
module Instruction = struct
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
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' = 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.t' list -> t =
fun pos f _ ->
ignore pos;
match f with
| T.Goto | T.XGoto ->
{ block_pos = pos; has_gt = true; is_gt = true; pos = None }
| T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None }
| _ -> default
(** Label for a loop *)
let location : S.pos -> string -> t = fun _ _ -> default
(** Comment *)
let comment : S.pos -> t = fun _ -> default
(** Raw expression *)
let expression : Expression.t' -> t = fun _ -> default
(** The content of a block is very linear, I only need to check the last element *)
let check_block : S.pos -> t list -> t =
fun pos instructions ->
let last_element =
List.fold_left instructions ~init:default ~f:(fun t instruction ->
let result = instruction 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 })
in
last_element
let if_ :
S.pos ->
(Expression.t', t) S.clause ->
elifs:(Expression.t', t) S.clause list ->
else_:(S.pos * t list) option ->
t =
fun pos clause ~elifs ~else_ ->
(* For each block, evaluate the instructions *)
let res, has_gt, is_gt =
List.fold_left ~init:([], false, false) (clause :: elifs)
~f:(fun (acc, has_gt, is_gt) clause ->
let pos, _, instructions = clause in
let clause_t = check_block pos instructions in
let has_gt = has_gt || clause_t.has_gt
and is_gt = is_gt || clause_t.is_gt in
((clause_t, pos) :: acc, has_gt, is_gt))
in
let else_pos, else_block =
match else_ with
| Some (pos, instructions) ->
let block = check_block pos instructions in
(pos, block)
| None -> (pos, default)
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
| 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 }
| 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) })
| _, _ -> { default with block_pos = pos; has_gt; is_gt })
let act : S.pos -> label:Expression.t' -> t list -> t =
fun pos ~label expressions ->
ignore label;
check_block pos expressions
let assign :
S.pos ->
(S.pos, Expression.t') S.variable ->
T.assignation_operator ->
Expression.t' ->
t =
fun _ _ _ _ -> default
end
module Location = struct
type t = Report.t list
let v = Fun.id
let location : unit -> S.pos -> Instruction.t' list -> t =
fun () _pos instructions ->
List.fold_left instructions ~init:[] ~f:(fun report t ->
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
|
