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