Added a new check to ensure that every call to another location points to an existing one

1 files changed, 159 insertions, 0 deletions

diff --git a/lib/syntax/locations.ml b/lib/syntax/locations.ml
new file mode 100644
index 0000000..17f33bd
--- /dev/null
+++ b/lib/syntax/locations.ml
@@ -0,0 +1,159 @@
+open StdLabels
+
+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