diff options
Diffstat (limited to 'lib/syntax/dead_end.ml')
| -rw-r--r-- | lib/syntax/dead_end.ml | 171 |
1 files changed, 0 insertions, 171 deletions
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml deleted file mode 100644 index c0dbc58..0000000 --- a/lib/syntax/dead_end.ml +++ /dev/null @@ -1,171 +0,0 @@ -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 |