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
|
open StdLabels
module S = Qsp_syntax.S
module T = Qsp_syntax.T
module Report = Qsp_syntax.Report
module IgnoreCaseString = struct
type t = string
let compare t1 t2 =
String.compare (String.lowercase_ascii t1) (String.lowercase_ascii t2)
let equal t1 t2 =
String.equal (String.lowercase_ascii t1) (String.lowercase_ascii t2)
end
module LocationSet = Set.Make (IgnoreCaseString)
module LocationCalls = Map.Make (IgnoreCaseString)
let identifier = "locations"
let description = "Ensure every call points to an existing location"
let is_global = true
let active = ref true
type t = {
locations : LocationSet.t;
calls : (string * S.pos) list LocationCalls.t;
}
type context = t ref
let initialize () =
ref { locations = LocationSet.empty; calls = LocationCalls.empty }
let finalize : context -> (string * Report.t) list =
fun context ->
LocationCalls.fold
(fun location positions acc ->
let message = Printf.sprintf "The location %s does not exists" location in
List.fold_left ~init:acc (List.rev positions)
~f:(fun acc (loc, position) ->
let report = Report.error position message in
(loc, report) :: acc))
!context.calls []
(** Register a new call to a defined location. *)
let registerCall : S.pos -> string -> t -> t =
fun pos location t ->
let file_name = (fst pos).Lexing.pos_fname in
match
IgnoreCaseString.equal location file_name
|| LocationSet.mem location t.locations
with
| true -> t
| false ->
(* The location is not yet defined, register the call for later *)
let calls =
LocationCalls.update location
(function
| None -> Some [ (file_name, pos) ]
| Some poss ->
Some
(let new_pos = (file_name, pos) in
new_pos :: poss))
t.calls
in
{ t with calls }
(** Add a new location in the list of all the collected elements *)
let registerLocation : string -> t -> t =
fun location t ->
let calls = LocationCalls.remove location t.calls
and locations = LocationSet.add location t.locations in
{ calls; locations }
(** The module Expression is pretty simple, we are only interrested by the
strings ( because only the first argument of [gt …] is read ).
If the string is too much complex, we just ignore it. *)
module Expression = struct
type t = string option
include Default.Expression (struct
type nonrec t = t
let default = None
end)
let v : t -> t' = Fun.id
(* Extract the litteral if this is a simple text *)
let literal : S.pos -> t' T.literal list -> t' =
fun _ ll -> match ll with Text lit :: [] -> Some lit | _ -> None
end
module Instruction = struct
type nonrec t = t -> t
type t' = t
let v : t -> t' = Fun.id
(** Keep a track of every gt or gs instruction *)
let call : S.pos -> T.keywords -> Expression.t' list -> t =
fun pos fn args t ->
match (fn, args) with
| T.Goto, Some dest :: _ -> registerCall pos dest t
| T.Gosub, Some dest :: _ -> registerCall pos dest t
| _ -> t
let location : S.pos -> string -> t = fun _ _ -> Fun.id
let comment : S.pos -> t = fun _ -> Fun.id
let expression : Expression.t' -> t = fun _ -> Fun.id
let if_ :
S.pos ->
(Expression.t', t) S.clause ->
elifs:(Expression.t', t) S.clause list ->
else_:(S.pos * t list) option ->
t =
fun _ clause ~elifs ~else_ t ->
let traverse_clause t clause =
let _, _, block = clause in
List.fold_left block ~init:t ~f:(fun t instruction -> instruction t)
in
let t = traverse_clause t clause in
let t = List.fold_left ~init:t ~f:traverse_clause elifs in
match else_ with
| None -> t
| Some (_, instructions) ->
List.fold_left instructions ~init:t ~f:(fun t instruction ->
instruction t)
let act : S.pos -> label:Expression.t' -> t list -> t =
fun _ ~label instructions t ->
ignore label;
List.fold_left instructions ~init:t ~f:(fun t instruction -> instruction t)
let assign :
S.pos ->
(S.pos, Expression.t') S.variable ->
T.assignation_operator ->
Expression.t' ->
t =
fun _ _ _ _ -> Fun.id
end
module Location = struct
type t = unit
let v : t -> Report.t list = fun () -> []
let location : context -> S.pos -> Instruction.t list -> t =
fun context pos instructions ->
(* Register the location *)
let file_name = (fst pos).Lexing.pos_fname in
let c = registerLocation file_name !context in
(* Then update the list of all the calls to the differents locations *)
context :=
List.fold_left instructions ~init:c ~f:(fun t instruction ->
instruction t)
end
|
