diff options
Diffstat (limited to 'lib/syntax/dead_end.ml')
-rw-r--r-- | lib/syntax/dead_end.ml | 91 |
1 files changed, 42 insertions, 49 deletions
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml index d1683cd..1240e72 100644 --- a/lib/syntax/dead_end.ml +++ b/lib/syntax/dead_end.ml @@ -10,11 +10,11 @@ module Expression = struct let default = () end) - let v : t -> t' * Report.t list = fun () -> ((), []) + let v : t -> t' = fun () -> () end module Instruction = struct - type expression = Expression.t' * Report.t list + type expression = Expression.t' type cause = Missing_else | Unchecked_path type state = { @@ -24,7 +24,7 @@ module Instruction = struct pos : (cause * S.pos) option; } - type t = state * Report.t list + type t = state type t' = state (** For each instruction, return thoses two informations : @@ -33,7 +33,7 @@ module Instruction = struct - the last instruction is a [gt] *) - let v : t -> t' * Report.t list = fun t -> t + let v : t -> t' = fun t -> t let default = { @@ -44,36 +44,33 @@ module Instruction = struct } (** Call for an instruction like [GT] or [*CLR] *) - let call : S.pos -> T.keywords -> expression list -> t S.repr = - fun pos f _ report -> + let call : S.pos -> T.keywords -> expression 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 }, report) - | T.Gosub -> - ({ block_pos = pos; has_gt = false; is_gt = true; pos = None }, report) - | _ -> (default, report) + { 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 S.repr = - fun _ _ report -> (default, report) + let location : S.pos -> string -> t = fun _ _ -> default (** Comment *) - let comment : S.pos -> t S.repr = fun _ report -> (default, report) + let comment : S.pos -> t = fun _ -> default (** Raw expression *) - let expression : expression -> t S.repr = fun _ report -> (default, report) + let expression : expression -> 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 S.repr list -> t S.repr = - fun pos instructions report -> + let check_block : S.pos -> t list -> t = + fun pos instructions -> let last_element = - List.fold_left instructions ~init:(default, report) - ~f:(fun (t, report) instruction -> - let result, report = instruction report in + 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 }, report)) + { result with block_pos = pos; is_gt; has_gt }) in last_element @@ -81,27 +78,27 @@ module Instruction = struct 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 -> + else_:(S.pos * t list) option -> + t = + fun pos clause ~elifs ~else_ -> (* 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 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, report = check_block pos instructions report 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 - (report, (clause_t, pos) :: acc, has_gt, is_gt)) + ((clause_t, pos) :: acc, has_gt, is_gt)) in - let else_pos, else_block, report = + let else_pos, else_block = match else_ with | Some (pos, instructions) -> - let block, report = check_block pos instructions report in - (pos, block, report) - | None -> (pos, default, report) + 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 @@ -110,7 +107,7 @@ module Instruction = struct (* 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) + | Some (v, _) -> v | None -> ( match (is_gt, has_gt) with | _, true -> ( @@ -119,41 +116,37 @@ module Instruction = struct 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) + { 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) }, - report )) - | _, _ -> ({ default with block_pos = pos; has_gt; is_gt }, report)) + { 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 S.repr list -> t S.repr = - fun pos ~label expressions report -> + let act : S.pos -> label:expression -> t list -> t = + fun pos ~label expressions -> ignore label; - check_block pos expressions report + check_block pos expressions let assign : S.pos -> (S.pos, expression) S.variable -> T.assignation_operator -> expression -> - t S.repr = - fun _ _ _ _ report -> (default, report) + t = + fun _ _ _ _ -> default end module Location = struct type t = unit - type instruction = (Instruction.t' * Report.t list) S.repr + type instruction = Instruction.t' - let location : S.pos -> instruction list -> (t * Report.t list) S.repr = - fun _pos instructions report -> + let location : S.pos -> instruction list -> t * Report.t list = + fun _pos instructions -> ( (), - List.fold_left instructions ~init:report ~f:(fun report instruction -> - let t, r = instruction [] in - - let report = List.rev_append r report in + List.fold_left instructions ~init:[] ~f:(fun report t -> match (t.Instruction.is_gt, t.Instruction.pos) with | false, Some (cause, value) -> ignore cause; |