From 0b75cd5bc0f7d0ad905bce5bebc6e47c927f64d7 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Mon, 16 Oct 2023 16:42:53 +0200
Subject: Used the dead-end checker in main analysis

---
 lib/syntax/S.ml         |   2 +-
 lib/syntax/check.ml     |  20 ++++--
 lib/syntax/dead_end.ml  | 167 ++++++++++++++++++++++++++++++++++++++++--------
 lib/syntax/dead_end.mli |   1 +
 lib/syntax/default.ml   |  35 ++++++----
 lib/syntax/report.ml    |   3 +
 lib/syntax/tree.ml      |   9 ++-
 lib/syntax/type_of.ml   |  10 ++-
 8 files changed, 196 insertions(+), 51 deletions(-)
 create mode 100644 lib/syntax/dead_end.mli

(limited to 'lib/syntax')

diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 3d86881..710eb59 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -81,7 +81,7 @@ module type Instruction = sig
     pos ->
     (expression, t) clause ->
     elifs:(expression, t) clause list ->
-    else_:t repr list ->
+    else_:(pos * t repr list) option ->
     t repr
 
   val act : pos -> label:expression -> t repr list -> t repr
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 3e9d255..3e01e64 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -464,13 +464,19 @@ module Make (A : App) = struct
         S.pos ->
         (expression, t) S.clause ->
         elifs:(expression, t) S.clause list ->
-        else_:t S.repr list ->
+        else_:(S.pos * t S.repr list) option ->
         t S.repr =
      fun pos clause ~elifs ~else_ report ->
       (* First, apply the report for all the instructions *)
       let report, clause = map_clause report clause in
       let report, elifs = List.fold_left_map elifs ~init:report ~f:map_clause in
-      let report, else_ = Helper.map_args report else_ in
+      let report, else_ =
+        match else_ with
+        | None -> (report, None)
+        | Some (pos, instructions) ->
+            let report, instructions = Helper.map_args report instructions in
+            (report, Some (pos, instructions))
+      in
       let report = ref report and len = Array.length A.t in
 
       let result =
@@ -485,9 +491,13 @@ module Make (A : App) = struct
             let clause = rebuild_clause i instr_witness expr_witness f clause
             and elifs =
               List.map elifs ~f:(rebuild_clause i instr_witness expr_witness f)
-            and elses = Helper.args_i else_ instr_witness i in
-
-            let else_ = List.rev elses.values in
+            and else_ =
+              match else_ with
+              | None -> None
+              | Some (pos, instructions) ->
+                  let elses = Helper.args_i instructions instr_witness i in
+                  Some (pos, List.rev elses.values)
+            in
 
             let value, r = A.Instruction.if_ pos clause ~elifs ~else_ !report in
             report := r;
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index bb78263..36c997f 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -1,53 +1,168 @@
 open StdLabels
 
-type pos = Lexing.position * Lexing.position
-type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
+module Expression = struct
+  type t = unit
+  type t' = unit
 
-module Expression = Default.Expression
+  include Default.Expression (struct
+    type nonrec t = t
+
+    let default = ()
+  end)
+
+  let v : t * Report.t list -> t' * Report.t list = Fun.id
+end
 
 module Instruction = struct
-  type expression = Default.Expression.t' S.repr
-  type repr = unit
+  type expression = Expression.t' S.repr
+  type cause = Missing_else | Unchecked_path
+
+  type t = {
+    block_pos : S.pos;
+    has_gt : bool;
+    is_gt : bool;
+    pos : (cause * S.pos) option;
+  }
+
+  type t' = t
+
+  (** For each instruction, return thoses two informations :
+
+      - the intruction contains at [gt] 
+      - the last instruction is a [gt]
+
+    *)
+  let v : t * Report.t list -> t' * Report.t list = Fun.id
+
+  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 : pos -> string -> expression list -> repr = fun _ _ _ -> ()
+  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 : pos -> string -> repr = fun _ _ -> ()
+  let location : S.pos -> string -> t S.repr =
+   fun _ _ report -> (default, report)
 
   (** Comment *)
-  let comment : pos -> repr = fun _ -> ()
+  let comment : S.pos -> t S.repr = fun _ report -> (default, report)
 
   (** Raw expression *)
-  let expression : expression -> repr = fun _ -> ()
+  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
 
-  type clause = pos * expression * repr list
+          (report, (clause_t, pos) :: acc, has_gt, is_gt))
+    in
 
-  let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
-   fun _ _ ~elifs ~else_ ->
-    ignore elifs;
-    ignore else_;
-    ()
+    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 act : pos -> label:expression -> repr list -> repr =
-   fun _ ~label _ ->
+    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 :
-      pos ->
+      S.pos ->
       (S.pos, expression) S.variable ->
       T.assignation_operator ->
       expression ->
-      repr =
-   fun _ _ _ _ -> ()
+      t S.repr =
+   fun _ _ _ _ report -> (default, report)
 end
 
 module Location = struct
-  type repr = Instruction.repr
-  type instruction = Instruction.repr
+  type t = unit
+  type instruction = Instruction.t
+
+  let location : S.pos -> instruction S.repr list -> t S.repr =
+   fun _pos instructions report ->
+    ( (),
+      List.fold_left instructions ~init:report ~f:(fun report instruction ->
+          let t, report = instruction report in
 
-  let location : pos -> instruction list -> repr =
-   fun _pos instructions ->
-    List.fold_left instructions ~init:() ~f:(fun () instruction -> instruction)
+          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
diff --git a/lib/syntax/dead_end.mli b/lib/syntax/dead_end.mli
new file mode 100644
index 0000000..ce48791
--- /dev/null
+++ b/lib/syntax/dead_end.mli
@@ -0,0 +1 @@
+include S.Analyzer with type Location.t = unit
diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml
index eed7f2b..dad5144 100644
--- a/lib/syntax/default.ml
+++ b/lib/syntax/default.ml
@@ -3,7 +3,13 @@
 This module is expected to be used when you only need to implement an analyze
 over a limited part of the whole syntax. *)
 
-module Expression = struct
+module type T = sig
+  type t
+
+  val default : t
+end
+
+module Expression (T' : T) = struct
   (** 
       Describe a variable, using the name in capitalized text, and an optionnal
       index.
@@ -11,28 +17,29 @@ module Expression = struct
       If missing, the index should be considered as [0].
    *)
 
-  type t = unit
-  type t' = unit
-
-  let ident : (S.pos, t S.repr) S.variable -> t S.repr =
-   fun _ report -> ((), report)
+  let ident : (S.pos, T'.t S.repr) S.variable -> T'.t S.repr =
+   fun _ report -> (T'.default, report)
 
   (*
         Basic values, text, number…
    *)
 
-  let integer : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
-  let literal : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
+  let integer : S.pos -> string -> T'.t S.repr =
+   fun _ _ report -> (T'.default, report)
+
+  let literal : S.pos -> string -> T'.t S.repr =
+   fun _ _ report -> (T'.default, report)
 
   (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
-  let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
-   fun _ _ _ report -> ((), report)
+  let function_ : S.pos -> T.function_ -> T'.t S.repr list -> T'.t S.repr =
+   fun _ _ _ report -> (T'.default, report)
 
   (** Unary operator like [-123] or [+'Text']*)
-  let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
-   fun _ _ _ report -> ((), report)
+  let uoperator : S.pos -> T.uoperator -> T'.t S.repr -> T'.t S.repr =
+   fun _ _ _ report -> (T'.default, report)
 
   (** Binary operator, for a comparaison, or an operation *)
-  let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
-   fun _ _ _ _ report -> ((), report)
+  let boperator :
+      S.pos -> T.boperator -> T'.t S.repr -> T'.t S.repr -> T'.t S.repr =
+   fun _ _ _ _ report -> (T'.default, report)
 end
diff --git a/lib/syntax/report.ml b/lib/syntax/report.ml
index 9ad24c3..9dae0f5 100644
--- a/lib/syntax/report.ml
+++ b/lib/syntax/report.ml
@@ -31,6 +31,9 @@ let pp_pos : Format.formatter -> pos -> unit =
 type t = { level : level; loc : pos; message : string }
 [@@deriving show { with_path = false }]
 
+let debug : pos -> string -> t =
+ fun loc message -> { level = Debug; loc; message }
+
 let warn : pos -> string -> t =
  fun loc message -> { level = Warn; loc; message }
 
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index fb6135f..85e130d 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -93,7 +93,7 @@ module Instruction :
       S.pos ->
       (expression, t) S.clause ->
       elifs:(expression, t) S.clause list ->
-      else_:t S.repr list ->
+      else_:(S.pos * t S.repr list) option ->
       t S.repr =
    fun pos predicate ~elifs ~else_ report ->
     let clause (pos, expr, repr) =
@@ -101,7 +101,12 @@ module Instruction :
       (pos, fst @@ expr [], repr)
     in
     let elifs = List.map ~f:clause elifs
-    and else_ = List.map ~f:(fun instr -> fst @@ instr []) else_ in
+    and else_ =
+      match else_ with
+      | None -> []
+      | Some (_, instructions) ->
+          List.map ~f:(fun instr -> fst @@ instr []) instructions
+    in
 
     (Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }, report)
 
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 0b62e95..b0d14ec 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -328,14 +328,18 @@ module Instruction = struct
       S.pos ->
       (expression, t) S.clause ->
       elifs:(expression, t) S.clause list ->
-      else_:t S.repr list ->
+      else_:(S.pos * t S.repr list) option ->
       t S.repr =
    fun _pos clause ~elifs ~else_ report ->
     (* Traverse the whole block recursively *)
     let report = fold_clause ((), report) clause in
     let report = List.fold_left elifs ~f:fold_clause ~init:report in
-    List.fold_left else_ ~init:report ~f:(fun ((), report) instruction ->
-        instruction report)
+
+    match else_ with
+    | None -> report
+    | Some (_, instructions) ->
+        List.fold_left instructions ~init:report
+          ~f:(fun ((), report) instruction -> instruction report)
 
   let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
    fun _pos ~label instructions report ->
-- 
cgit v1.2.3