aboutsummaryrefslogtreecommitdiff
path: root/lib/checks
diff options
context:
space:
mode:
Diffstat (limited to 'lib/checks')
-rw-r--r--lib/checks/check.ml433
-rw-r--r--lib/checks/check.mli69
-rw-r--r--lib/checks/compose.ml127
-rw-r--r--lib/checks/dead_end.ml174
-rw-r--r--lib/checks/dead_end.mli6
-rw-r--r--lib/checks/default.ml45
-rw-r--r--lib/checks/dune9
-rw-r--r--lib/checks/dup_test.ml192
-rw-r--r--lib/checks/dup_test.mli1
-rw-r--r--lib/checks/get_type.ml124
-rw-r--r--lib/checks/locations.ml162
-rw-r--r--lib/checks/nested_strings.ml159
-rw-r--r--lib/checks/nested_strings.mli1
-rw-r--r--lib/checks/type_of.ml491
-rw-r--r--lib/checks/type_of.mli7
-rw-r--r--lib/checks/write_only.ml220
16 files changed, 2220 insertions, 0 deletions
diff --git a/lib/checks/check.ml b/lib/checks/check.ml
new file mode 100644
index 0000000..76d5c34
--- /dev/null
+++ b/lib/checks/check.ml
@@ -0,0 +1,433 @@
+module Id = Type.Id
+
+(** The the Id module, wrap a value in an existencial type with a witness
+ associate with. *)
+type result = R : { value : 'a; witness : 'a Id.t } -> result
+
+let get : type a. a Id.t -> result -> a option =
+ fun typeid (R { value; witness }) ->
+ match Id.provably_equal typeid witness with
+ | Some Type.Equal -> Some value
+ | None -> None
+
+type t =
+ | E : {
+ module_ :
+ (module Qsp_syntax.S.Analyzer
+ with type Expression.t = 'a
+ and type Expression.t' = 'b
+ and type Instruction.t = 'c
+ and type Instruction.t' = 'd
+ and type Location.t = 'e
+ and type context = 'f);
+ expr_witness : 'a Id.t;
+ expr' : 'b Id.t;
+ instr_witness : 'c Id.t;
+ instr' : 'd Id.t;
+ location_witness : 'e Id.t;
+ context : 'f Id.t;
+ }
+ -> t
+
+let build :
+ (module Qsp_syntax.S.Analyzer
+ with type Expression.t = _
+ and type Expression.t' = _
+ and type Instruction.t = _
+ and type Instruction.t' = _
+ and type Location.t = 'a
+ and type context = _) ->
+ 'a Id.t * t =
+ fun module_ ->
+ let expr_witness = Id.make ()
+ and expr' = Id.make ()
+ and instr_witness = Id.make ()
+ and instr' = Id.make ()
+ and location_witness = Id.make ()
+ and context = Id.make () in
+ let t =
+ E
+ {
+ module_;
+ expr_witness;
+ expr';
+ instr_witness;
+ instr';
+ location_witness;
+ context;
+ }
+ in
+ (location_witness, t)
+
+let get_module : t -> (module Qsp_syntax.S.Analyzer) =
+ fun (E { module_; _ }) -> (module_ :> (module Qsp_syntax.S.Analyzer))
+
+module type App = sig
+ val t : t array
+end
+
+open StdLabels
+
+module Helper = struct
+ type 'a expr_list = { witness : 'a Id.t; values : 'a list }
+
+ let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list =
+ fun args witness i ->
+ let result =
+ List.fold_left args ~init:{ values = []; witness }
+ ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list ->
+ match get witness (Array.get t i) with
+ | None -> failwith "Does not match"
+ | Some value_1 -> { values = value_1 :: values; witness })
+ in
+ { result with values = result.values }
+end
+
+module Make (A : App) = struct
+ let identifier = "main_checker"
+ let description = "Internal module"
+ let is_global = false
+ let active = ref false
+
+ type context = result Array.t
+ (** We associate each context from the differents test in an array. The
+ context for this module is a sort of context of contexts *)
+
+ (** Initialize each test, and keep the result in the context. *)
+ let initialize : unit -> context =
+ fun () ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); context; _ }) ->
+ let value = S.initialize () in
+ R { value; witness = context })
+
+ let finalize : result Array.t -> (string * Qsp_syntax.Report.t) list =
+ fun context_array ->
+ let _, report =
+ Array.fold_left A.t ~init:(0, [])
+ ~f:(fun (i, acc) (E { module_ = (module S); context; _ }) ->
+ let result = Array.get context_array i in
+ let local_context = Option.get (get context result) in
+ let reports = S.finalize local_context in
+ (i + 1, List.rev_append reports acc))
+ in
+ report
+
+ (* Global variable for the whole module *)
+ let len = Array.length A.t
+
+ module Expression : Qsp_syntax.S.Expression with type t' = result array =
+ struct
+ type t = result array
+ type t' = result array
+
+ let literal : Qsp_syntax.S.pos -> t Qsp_syntax.T.literal list -> t =
+ fun pos values ->
+ Array.mapi A.t ~f:(fun i (E { module_ = (module S); expr_witness; _ }) ->
+ (* Map every values to the Checker *)
+ let values' =
+ List.map values
+ ~f:
+ (Qsp_syntax.T.map_litteral ~f:(fun expr ->
+ Option.get (get expr_witness (Array.get expr i))))
+ in
+ let value = S.Expression.literal pos values' in
+ R { value; witness = expr_witness })
+
+ let integer : Qsp_syntax.S.pos -> string -> t =
+ fun pos value ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) ->
+ let value = S.Expression.integer pos value in
+ R { value; witness = expr_witness })
+
+ (** Unary operator like [-123] or [+'Text']*)
+ let uoperator : Qsp_syntax.S.pos -> Qsp_syntax.T.uoperator -> t -> t =
+ fun pos op values ->
+ (* Evaluate the nested expression *)
+ let results = values in
+
+ (* Now evaluate the remaining expression.
+
+ Traverse both the module the apply, and the matching expression already
+ evaluated.
+
+ It’s easer to use [map] and declare [report] as reference instead of
+ [fold_left2] and accumulate the report inside the closure, because I
+ don’t manage the order of the results.
+ *)
+ let results =
+ Array.map2 A.t results
+ ~f:(fun (E { module_ = (module S); expr_witness; _ }) value ->
+ match get expr_witness value with
+ | None -> failwith "Does not match"
+ | Some value ->
+ (* Evaluate the single expression *)
+ let value = S.Expression.uoperator pos op value in
+ R { witness = expr_witness; value })
+ in
+ results
+
+ (** Basically the same as uoperator, but operate over two operands instead
+ of a single one. *)
+ let boperator : Qsp_syntax.S.pos -> Qsp_syntax.T.boperator -> t -> t -> t =
+ fun pos op expr1 expr2 ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+ match
+ ( get expr_witness (Array.get expr1 i),
+ get expr_witness (Array.get expr2 i) )
+ with
+ | Some value_1, Some value_2 ->
+ let value = S.Expression.boperator pos op value_1 value_2 in
+ R { witness = expr_witness; value }
+ | _ -> failwith "Does not match")
+
+ (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
+ let function_ : Qsp_syntax.S.pos -> Qsp_syntax.T.function_ -> t list -> t =
+ fun pos func args ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+ (* Extract the arguments for each module *)
+ let args_i = List.rev (Helper.expr_i args expr_witness i).values in
+ let value = S.Expression.function_ pos func args_i in
+ R { witness = expr_witness; value })
+
+ let ident : (Qsp_syntax.S.pos, t) Qsp_syntax.S.variable -> t =
+ fun { pos : Qsp_syntax.S.pos; name : string; index : t option } ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+
+ match index with
+ | None ->
+ (* Easest case, just return the plain ident *)
+ let value = S.Expression.ident { pos; name; index = None } in
+ R { witness = expr_witness; value }
+ | Some t -> (
+ match get expr_witness (Array.get t i) with
+ | None -> failwith "Does not match"
+ | Some value_1 ->
+ let value =
+ S.Expression.ident { pos; name; index = Some value_1 }
+ in
+ R { witness = expr_witness; value }))
+
+ (** Convert each internal represention for the expression into its external
+ representation *)
+ let v : t -> t' =
+ fun t ->
+ let result =
+ Array.map2 A.t t
+ ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result ->
+ match get expr_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = S.Expression.v value in
+ R { witness = expr'; value })
+ in
+ result
+ end
+
+ module Instruction :
+ Qsp_syntax.S.Instruction
+ with type expression = Expression.t'
+ and type t' = result array = struct
+ type expression = Expression.t'
+ type t = result array
+ type t' = result array
+
+ let location : Qsp_syntax.S.pos -> string -> t =
+ fun pos label ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.location pos label in
+ R { value; witness = instr_witness })
+
+ let comment : Qsp_syntax.S.pos -> t =
+ fun pos ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.comment pos in
+ R { value; witness = instr_witness })
+
+ let expression : expression -> t =
+ fun expr ->
+ Array.map2 A.t expr
+ ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result ->
+ match get expr' result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ (* The evaluate the instruction *)
+ let value = S.Instruction.expression value in
+ R { value; witness = instr_witness })
+
+ let call : Qsp_syntax.S.pos -> Qsp_syntax.T.keywords -> expression list -> t
+ =
+ fun pos keyword args ->
+ (* The arguments are given like an array of array. Each expression is
+ actually the list of each expression in the differents modules. *)
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr'; instr_witness; _ }) =
+ Array.get A.t i
+ in
+
+ let values = List.rev (Helper.expr_i args expr' i).values in
+
+ let value = S.Instruction.call pos keyword values in
+ R { witness = instr_witness; value })
+
+ let act : Qsp_syntax.S.pos -> label:expression -> t list -> t =
+ fun pos ~label instructions ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+ let values =
+ List.rev (Helper.expr_i instructions instr_witness i).values
+ in
+
+ match get expr' (Array.get label i) with
+ | None -> failwith "Does not match"
+ | Some label_i ->
+ let value = S.Instruction.act pos ~label:label_i values in
+ R { witness = instr_witness; value })
+
+ (* I think it’s one of the longest module I’ve ever written in OCaml… *)
+
+ let assign :
+ Qsp_syntax.S.pos ->
+ (Qsp_syntax.S.pos, expression) Qsp_syntax.S.variable ->
+ Qsp_syntax.T.assignation_operator ->
+ expression ->
+ t =
+ fun pos { pos = var_pos; name; index } op expression ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+
+ let index_i =
+ Option.map
+ (fun expression ->
+ Option.get (get expr' (Array.get expression i)))
+ index
+ in
+ let variable =
+ Qsp_syntax.S.{ pos = var_pos; name; index = index_i }
+ in
+
+ match get expr' (Array.get expression i) with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = A.Instruction.assign pos variable op value in
+
+ R { value; witness = instr_witness })
+
+ let rebuild_clause :
+ type a b.
+ int ->
+ a Id.t ->
+ b Id.t ->
+ Qsp_syntax.S.pos * result array * result array list ->
+ (b, a) Qsp_syntax.S.clause =
+ fun i instr_witness expr' clause ->
+ let pos_clause, expr_clause, ts = clause in
+ match get expr' (Array.get expr_clause i) with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let ts = Helper.expr_i ts instr_witness i in
+ let ts = List.rev ts.values in
+ let clause = (pos_clause, value, ts) in
+ clause
+
+ let if_ :
+ Qsp_syntax.S.pos ->
+ (expression, t) Qsp_syntax.S.clause ->
+ elifs:(expression, t) Qsp_syntax.S.clause list ->
+ else_:(Qsp_syntax.S.pos * t list) option ->
+ t =
+ fun pos clause ~elifs ~else_ ->
+ (* First, apply the report for all the instructions *)
+ let else_ =
+ match else_ with
+ | None -> None
+ | Some (pos, instructions) -> Some (pos, instructions)
+ in
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+
+ let clause = rebuild_clause i instr_witness expr' clause
+ and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr')
+ and else_ =
+ match else_ with
+ | None -> None
+ | Some (pos, instructions) ->
+ let elses = Helper.expr_i instructions instr_witness i in
+ Some (pos, List.rev elses.values)
+ in
+
+ let value = A.Instruction.if_ pos clause ~elifs ~else_ in
+ R { value; witness = instr_witness })
+
+ (** This code is almost a copy/paste from Expression.v but I did not found
+ a way to factorize it. *)
+ let v : t -> t' =
+ fun t ->
+ let result =
+ Array.map2 A.t t
+ ~f:(fun
+ (E { module_ = (module S); instr_witness; instr'; _ }) result ->
+ match get instr_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = S.Instruction.v value in
+ R { witness = instr'; value })
+ in
+ result
+ end
+
+ module Location :
+ Qsp_syntax.S.Location
+ with type t = result array
+ and type instruction = Instruction.t'
+ and type context := context = struct
+ type instruction = Instruction.t'
+ type t = result array
+
+ let location : context -> Qsp_syntax.S.pos -> instruction list -> t =
+ fun local_context pos args ->
+ ignore pos;
+
+ let result =
+ Array.init len ~f:(fun i ->
+ let (E
+ { module_ = (module A); instr'; location_witness; context; _ })
+ =
+ Array.get A.t i
+ in
+
+ let local_context =
+ Option.get (get context (Array.get local_context i))
+ in
+
+ let instructions = List.rev (Helper.expr_i args instr' i).values in
+ let value = A.Location.location local_context pos instructions in
+ R { value; witness = location_witness })
+ in
+ result
+
+ let v : t -> Qsp_syntax.Report.t list =
+ fun args ->
+ let report = ref [] in
+ let () =
+ Array.iteri args ~f:(fun i result ->
+ let (E { module_ = (module A); location_witness; _ }) =
+ Array.get A.t i
+ in
+ match get location_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let re = A.Location.v value in
+ report := List.rev_append re !report)
+ in
+ !report
+ end
+end
diff --git a/lib/checks/check.mli b/lib/checks/check.mli
new file mode 100644
index 0000000..321b67b
--- /dev/null
+++ b/lib/checks/check.mli
@@ -0,0 +1,69 @@
+(** This module is a meta-checker. It will take many checkers and aggregate
+ their result together before providing an unified result.
+
+ The modules required to be declared before being used, using the [build]
+ method, and provided as an array :
+
+ {[
+ let _, e1 = build (module …)
+ let _, e2 = build (module …)
+
+ module Check = Make (struct
+ let t = [| e1; e2 |]
+ end)
+ ]}
+*)
+
+module Id : sig
+ type 'a t
+ (** The type created on-the-fly. *)
+end
+
+type t =
+ | E : {
+ module_ :
+ (module Qsp_syntax.S.Analyzer
+ with type Expression.t = 'a
+ and type Expression.t' = 'b
+ and type Instruction.t = 'c
+ and type Instruction.t' = 'd
+ and type Location.t = 'e
+ and type context = 'f);
+ expr_witness : 'a Id.t;
+ expr' : 'b Id.t;
+ instr_witness : 'c Id.t;
+ instr' : 'd Id.t;
+ location_witness : 'e Id.t;
+ context : 'f Id.t;
+ }
+ -> t (** Type of check to apply *)
+
+val build :
+ (module Qsp_syntax.S.Analyzer
+ with type Expression.t = _
+ and type Expression.t' = _
+ and type Instruction.t = _
+ and type Instruction.t' = _
+ and type Location.t = 'a
+ and type context = _) ->
+ 'a Id.t * t
+(** Build a new check from a module following S.Analyzer signature.
+ypeid
+ Return the result type which hold the final result value, and checker
+ itself. *)
+
+val get_module : t -> (module Qsp_syntax.S.Analyzer)
+
+type result
+
+val get : 'a Id.t -> result -> 'a option
+(** The method [get] can be used to get the internal value for one of the
+ checker used.
+ *)
+
+module Make (A : sig
+ val t : t array
+end) : sig
+ include Qsp_syntax.S.Analyzer with type Location.t = result array
+end
+[@@warning "-67"]
diff --git a/lib/checks/compose.ml b/lib/checks/compose.ml
new file mode 100644
index 0000000..4517755
--- /dev/null
+++ b/lib/checks/compose.ml
@@ -0,0 +1,127 @@
+(** Build a module with the result from another one module *)
+
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+
+(** Make a module lazy *)
+module Lazier (E : S.Expression) :
+ S.Expression with type t' = E.t' Lazy.t and type t = E.t Lazy.t = struct
+ type t = E.t Lazy.t
+ type t' = E.t' Lazy.t
+
+ let v : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v
+ let integer : S.pos -> string -> t = fun pos i -> lazy (E.integer pos i)
+
+ let ident : (S.pos, t) S.variable -> t =
+ fun { pos; name : string; index : t option } ->
+ lazy (E.ident { pos; name; index = Option.map Lazy.force index })
+
+ let literal : S.pos -> t T.literal list -> t =
+ fun pos litts ->
+ lazy
+ (let e_litts = List.map litts ~f:(T.map_litteral ~f:Lazy.force) in
+ E.literal pos e_litts)
+
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos f e ->
+ lazy
+ (let e' = List.map ~f:Lazy.force e in
+ E.function_ pos f e')
+
+ let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos op t ->
+ let t' = lazy (E.uoperator pos op (Lazy.force t)) in
+ t'
+
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos op t1 t2 ->
+ let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
+ t'
+end
+
+(** Build an expression module with the result from another expression. The
+ signature of the fuctions is a bit different, as they all receive the
+ result from the previous evaluated element in argument. *)
+module Expression (E : S.Expression) = struct
+ module type SIG = sig
+ type t
+ type t'
+
+ (* Override the type [t] in the definition of all the functions. The
+ signatures differs a bit from the standard signature as they get the
+ result from E.t in last argument *)
+
+ val ident : (S.pos, E.t' Lazy.t * t) S.variable -> E.t' Lazy.t -> t
+ val integer : S.pos -> string -> E.t' Lazy.t -> t
+ val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t
+
+ val function_ :
+ S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t
+
+ val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t
+
+ val boperator :
+ S.pos ->
+ T.boperator ->
+ E.t' Lazy.t * t ->
+ E.t' Lazy.t * t ->
+ E.t' Lazy.t ->
+ t
+
+ val v : E.t' Lazy.t * t -> t'
+ (** Convert from the internal representation to the external one. *)
+ end
+
+ (* Create a lazy version of the module *)
+ module E = Lazier (E)
+
+ module Make (M : SIG) : S.Expression with type t' = M.t' = struct
+ type t = E.t * M.t
+ type t' = M.t'
+
+ let v' : E.t -> E.t' = E.v
+ let v : t -> t' = fun (type_of, v) -> M.v (v' type_of, v)
+
+ let ident : (S.pos, t) S.variable -> t =
+ fun { pos; name : string; index : t option } ->
+ let t' = E.ident { pos; name; index = Option.map fst index } in
+ let index' = Option.map (fun (e, m) -> (v' e, m)) index in
+ (t', M.ident { pos; name; index = index' } (v' t'))
+
+ let integer : S.pos -> string -> t =
+ fun pos i ->
+ let t' = E.integer pos i in
+ (t', M.integer pos i (v' t'))
+
+ let literal : S.pos -> t T.literal list -> t =
+ fun pos litts ->
+ let litts' =
+ List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m)))
+ in
+
+ let t' =
+ let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
+ E.literal pos e_litts
+ in
+ (t', M.literal pos litts' (v' t'))
+
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos f expressions ->
+ let e = List.map ~f:fst expressions
+ and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in
+
+ let t' = E.function_ pos f e in
+ (t', M.function_ pos f expressions' (v' t'))
+
+ let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos op (t, expr) ->
+ let t' = E.uoperator pos op t in
+ (t', M.uoperator pos op (v' t, expr) (v' t'))
+
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos op (t1, expr1) (t2, expr2) ->
+ let t' = E.boperator pos op t1 t2 in
+ (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
+ end
+end
diff --git a/lib/checks/dead_end.ml b/lib/checks/dead_end.ml
new file mode 100644
index 0000000..629a966
--- /dev/null
+++ b/lib/checks/dead_end.ml
@@ -0,0 +1,174 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+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
diff --git a/lib/checks/dead_end.mli b/lib/checks/dead_end.mli
new file mode 100644
index 0000000..d8fe7d6
--- /dev/null
+++ b/lib/checks/dead_end.mli
@@ -0,0 +1,6 @@
+(** Checker looking for the dead ends in the source.
+
+ A dead end is a state where the user does not have any action.
+ *)
+
+include Qsp_syntax.S.Analyzer
diff --git a/lib/checks/default.ml b/lib/checks/default.ml
new file mode 100644
index 0000000..a2b53f6
--- /dev/null
+++ b/lib/checks/default.ml
@@ -0,0 +1,45 @@
+(** Default implementation which does nothing.
+
+This module is expected to be used when you only need to implement an analyze
+over a limited part of the whole syntax. *)
+
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+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.
+
+ If missing, the index should be considered as [0].
+ *)
+
+ type t' = T'.t
+
+ let ident : (S.pos, T'.t) S.variable -> T'.t = fun _ -> T'.default
+
+ (*
+ Basic values, text, number…
+ *)
+
+ let integer : S.pos -> string -> T'.t = fun _ _ -> T'.default
+ let literal : S.pos -> T'.t T.literal list -> T'.t = fun _ _ -> T'.default
+
+ (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
+ let function_ : S.pos -> T.function_ -> T'.t list -> T'.t =
+ fun _ _ _ -> T'.default
+
+ (** Unary operator like [-123] or [+'Text']*)
+ let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> T'.default
+
+ (** Binary operator, for a comparaison, or an operation *)
+ let boperator : S.pos -> T.boperator -> T'.t -> T'.t -> T'.t =
+ fun _ _ _ _ -> T'.default
+end
diff --git a/lib/checks/dune b/lib/checks/dune
new file mode 100644
index 0000000..d7db2f3
--- /dev/null
+++ b/lib/checks/dune
@@ -0,0 +1,9 @@
+(library
+ (name qsp_checks)
+ (libraries
+ qsp_syntax
+ )
+
+ (preprocess (pps
+ ppx_deriving.show ppx_deriving.enum
+ ppx_deriving.eq )))
diff --git a/lib/checks/dup_test.ml b/lib/checks/dup_test.ml
new file mode 100644
index 0000000..e392445
--- /dev/null
+++ b/lib/checks/dup_test.ml
@@ -0,0 +1,192 @@
+(** This module check for duplicated tests in the source.contents
+
+
+ This in intended to identify the copy/paste errors, where one location
+ check for the same arguments twice or more.
+ *)
+
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+module Tree = Qsp_syntax.Tree
+
+let identifier = "duplicate_test"
+let description = "Check for duplicate tests"
+let is_global = false
+let active = ref true
+
+type context = unit
+
+let initialize = Fun.id
+let finalize () = []
+
+module Expression = Tree.Expression
+
+(** Build a Hashtbl over the expression, ignoring the location in the
+ expression *)
+module Table = Hashtbl.Make (struct
+ type t = Expression.t'
+
+ let equal : t -> t -> bool = Tree.Expression.eq (fun _ _ -> true)
+ let hash : t -> int = Tree.Expression.hash (fun _ -> 0)
+end)
+
+module Instruction = struct
+ type state = {
+ predicates : (Expression.t' * S.pos) list;
+ duplicates : (Expression.t' * S.pos list) list;
+ }
+ (** Keep the list of all the predicates and their position in a block, and
+ the list of all the identified duplicated values. *)
+
+ type t = state
+ type t' = state
+
+ let v : t -> t' = fun t -> t
+ let default = { predicates = []; duplicates = [] }
+
+ (** 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
+
+ let check_duplicates :
+ (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list =
+ fun predicates ->
+ let table = Table.create 5 in
+ let () = List.to_seq predicates |> Table.add_seq table in
+
+ Table.to_seq_keys table
+ |> Seq.group (Tree.Expression.eq (fun _ _ -> true))
+ |> Seq.filter_map (fun keys ->
+ (* Only take the first element for each group, we don’t need to
+ repeat the key *)
+ match Seq.uncons keys with
+ | None -> None
+ | Some (hd, _) -> (
+ match Table.find_all table hd with
+ | [] | _ :: [] -> None
+ | other -> Some (hd, other)))
+ |> List.of_seq
+
+ (** Evaluate a clause.
+ This function does two things :
+ - report all errors from the bottom to top
+ - add the clause in the actual level *)
+ let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t
+ =
+ fun ?pos t (pos2, predicate, blocks) ->
+ let pos = Option.value ~default:pos2 pos in
+
+ (* Remove the clauses using the function rnd because they repeating the
+ same clause can generate a different result *)
+ let should_discard =
+ Tree.Expression.exists predicate ~f:(function
+ | Tree.Ast.Function (_, T.Rand, _) | Tree.Ast.Function (_, T.Rnd, _) ->
+ true
+ | _ -> false)
+ in
+
+ {
+ predicates =
+ (match should_discard with
+ | false -> (predicate, pos) :: t.predicates
+ | true -> t.predicates);
+ duplicates =
+ List.fold_left blocks ~init:t.duplicates ~f:(fun acc t ->
+ List.rev_append t.duplicates acc);
+ }
+
+ 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_ ->
+ ignore else_;
+ (* Collect all the if clauses from this block, wait for the parent block to
+ check each case for duplicates. *)
+ let init = predicate_of_clause ~pos default clause in
+ let state = List.fold_left elifs ~init ~f:predicate_of_clause in
+ {
+ state with
+ duplicates = check_duplicates state.predicates @ state.duplicates;
+ }
+
+ let act : S.pos -> label:Expression.t' -> t list -> t =
+ fun _pos ~label expressions ->
+ ignore label;
+ (* Collect all the elements reported from bottom to up. *)
+ List.fold_left ~init:default expressions ~f:(fun state ex ->
+ {
+ predicates = [];
+ duplicates = List.rev_append ex.duplicates state.duplicates;
+ })
+
+ let assign :
+ S.pos ->
+ (S.pos, Expression.t') S.variable ->
+ T.assignation_operator ->
+ Expression.t' ->
+ t =
+ fun _ _ _ _ -> default
+
+ let call : S.pos -> T.keywords -> Expression.t' list -> t =
+ fun _ _ _ -> default
+end
+
+module Location = struct
+ type t = (Expression.t' * S.pos list) list
+
+ type context = unit
+ (** No context *)
+
+ (** Check if the given expression is involving the variable ARGS or $ARGS *)
+ let is_args : Expression.t' -> bool = function
+ | Tree.Ast.Ident { name; _ } ->
+ String.equal name "ARGS" || String.equal name "$ARGS"
+ | _ -> false
+
+ let location : context -> S.pos -> Instruction.t' list -> t =
+ fun () _ block ->
+ (* Filter the tests from the top level and only keep them testing ARGS *)
+ let duplicates =
+ List.map block ~f:(fun t ->
+ List.filter_map t.Instruction.predicates ~f:(fun v ->
+ match (Tree.Expression.exists ~f:is_args) (fst v) with
+ | true -> Some v
+ | false -> None))
+ |> List.concat |> Instruction.check_duplicates
+ in
+ List.fold_left ~init:duplicates block ~f:(fun state ex ->
+ List.rev_append ex.Instruction.duplicates state)
+
+ (** Create the report message *)
+ let v' : Expression.t' * S.pos list -> Report.t option =
+ fun (expr, pos) ->
+ ignore expr;
+ match (List.sort ~cmp:Report.compare_pos) pos with
+ | [] -> None
+ | _ :: [] -> None
+ | hd :: tl ->
+ let message =
+ Format.asprintf "This case is duplicated line(s) %a"
+ (Format.pp_print_list
+ ~pp_sep:(fun f () -> Format.pp_print_char f ',')
+ Report.pp_line)
+ tl
+ in
+
+ (* Report all the messages as error. They do not break the game, but
+ there is no question if it should *)
+ Some (Report.error hd message)
+
+ let v : t -> Report.t list =
+ fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare
+end
diff --git a/lib/checks/dup_test.mli b/lib/checks/dup_test.mli
new file mode 100644
index 0000000..6446c67
--- /dev/null
+++ b/lib/checks/dup_test.mli
@@ -0,0 +1 @@
+include Qsp_syntax.S.Analyzer
diff --git a/lib/checks/get_type.ml b/lib/checks/get_type.ml
new file mode 100644
index 0000000..b34dc17
--- /dev/null
+++ b/lib/checks/get_type.ml
@@ -0,0 +1,124 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+type type_of =
+ | Integer (** A numeric value *)
+ | Bool (** A boolean, not a real type *)
+ | String (** String value *)
+ | NumericString
+ [@printer fun fmt _ -> Format.pp_print_string fmt "Integer as String"]
+ (** String containing a numeric value *)
+[@@deriving show { with_path = false }, eq]
+
+type t = Variable of type_of | Raw of type_of [@@deriving show, eq]
+type t' = t
+
+let v = Fun.id
+let get_type : t -> type_of = function Raw r -> r | Variable r -> r
+
+let map : t -> type_of -> t =
+ fun t type_of ->
+ match t with Raw _ -> Raw type_of | Variable _ -> Variable type_of
+
+let get_nature : t -> t -> type_of -> t =
+ fun t1 t2 type_of ->
+ match (t1, t2) with
+ | Variable _, _ -> Variable type_of
+ | _, Variable _ -> Variable type_of
+ | Raw _, Raw _ -> Raw type_of
+
+let integer : S.pos -> string -> t = fun _ _ -> Raw Integer
+
+let ident : (S.pos, 'any) S.variable -> t =
+ fun var ->
+ match var.name.[0] with '$' -> Variable String | _ -> Variable Integer
+
+let literal : S.pos -> t T.literal list -> t =
+ fun pos values ->
+ ignore pos;
+ let init = None in
+ let typed =
+ List.fold_left values ~init ~f:(fun state -> function
+ | T.Text t -> (
+ (* Tranform the type, but keep the information is it’s a raw data
+ or a variable one *)
+ let nature = Option.value ~default:(Raw Integer) state in
+ match (Option.map get_type state, int_of_string_opt t) with
+ | None, Some _
+ | Some Integer, Some _
+ | Some NumericString, Some _
+ | Some Bool, Some _ ->
+ Some (map nature NumericString)
+ | _, _ ->
+ if String.equal "" t then
+ (* If the text is empty, ignore it *)
+ state
+ else Some (map nature String))
+ | T.Expression t -> (
+ let nature = Option.value ~default:(Raw Integer) state in
+ match (Option.map get_type state, get_type t) with
+ | None, Integer | Some NumericString, Integer ->
+ Some (get_nature nature t NumericString)
+ | _ -> Some (map nature String)))
+ in
+ let result = Option.value ~default:(Raw String) typed in
+ result
+
+let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos operator t ->
+ ignore pos;
+ match operator with Add -> t | Neg | No -> Raw Integer
+
+let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos operator t1 t2 ->
+ ignore pos;
+ match operator with
+ | T.Plus -> (
+ match (get_type t1, get_type t2) with
+ | Integer, Integer -> get_nature t1 t2 Integer
+ | String, _ -> get_nature t1 t2 String
+ | _, String -> get_nature t1 t2 String
+ | (_ as t), Bool -> get_nature t1 t2 t
+ | Bool, (_ as t) -> get_nature t1 t2 t
+ | (_ as t), NumericString -> get_nature t1 t2 t
+ | NumericString, (_ as t) -> get_nature t1 t2 t)
+ | T.Eq | T.Neq -> get_nature t1 t2 Bool
+ | T.Mod | T.Minus | T.Product | T.Div -> get_nature t1 t2 Integer
+ | T.And | T.Or -> get_nature t1 t2 Bool
+ | Lt | Gte | Lte | Gt -> get_nature t1 t2 Bool
+
+let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos function_ params ->
+ ignore pos;
+ match function_ with
+ | Dyneval | Dyneval' -> Variable NumericString
+ | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Getobj | Instr | Isplay ->
+ Variable Integer
+ | Desc' | Getobj' -> Variable String
+ | Func | Func' -> Variable NumericString
+ | Iif | Iif' -> ( match params with _ :: t :: _ -> t | _ -> Raw Bool)
+ | Input | Input' -> Variable NumericString
+ | Isnum -> Raw Bool
+ | Lcase | Lcase' | Ucase | Ucase' -> Raw String
+ | Len -> Raw Integer
+ | Loc -> Variable Bool
+ | Max | Max' | Min | Min' -> (
+ try List.hd params with Failure _ -> Raw Bool)
+ | Mid | Mid' -> Variable String
+ | Msecscount -> Raw Integer
+ | Rand -> Raw Integer
+ | Replace -> Variable String
+ | Replace' -> Variable String
+ | Rgb -> Raw Integer
+ | Rnd -> Raw Integer
+ | Selact -> Variable String
+ | Str | Str' -> Raw String
+ | Strcomp -> Raw Bool
+ | Strfind -> Variable String
+ | Strfind' -> Variable String
+ | Strpos -> Raw Integer
+ | Trim -> Variable String
+ | Trim' -> Variable String
+ | Val -> Raw Integer
diff --git a/lib/checks/locations.ml b/lib/checks/locations.ml
new file mode 100644
index 0000000..8ee6ffa
--- /dev/null
+++ b/lib/checks/locations.ml
@@ -0,0 +1,162 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+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
diff --git a/lib/checks/nested_strings.ml b/lib/checks/nested_strings.ml
new file mode 100644
index 0000000..e4ffb68
--- /dev/null
+++ b/lib/checks/nested_strings.ml
@@ -0,0 +1,159 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+let identifier = "escaped_string"
+let description = "Check for unnecessary use of expression encoded in string"
+let is_global = false
+let active = ref true
+
+type context = unit
+
+let initialize = Fun.id
+let finalize () = []
+
+module TypeBuilder = Compose.Expression (Get_type)
+
+module Expression = TypeBuilder.Make (struct
+ type t = Report.t list
+ type t' = Report.t list
+
+ let v : Get_type.t Lazy.t * t -> t' = snd
+
+ (** Identify the expressions reprented as string. That’s here that the report
+ are added.
+
+ All the rest of the module only push thoses warning to the top level. *)
+ let literal :
+ S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t
+ =
+ fun pos content _type_of ->
+ match content with
+ | [ T.Expression (t', _); T.Text "" ] -> (
+ match Get_type.get_type (Lazy.force t') with
+ | Get_type.Integer -> []
+ | _ ->
+ let msg = Report.debug pos "This expression can be simplified" in
+ [ msg ])
+ | _ -> []
+
+ let ident :
+ (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t =
+ fun variable _type_of ->
+ match variable.index with None -> [] | Some (_, t) -> t
+
+ let integer : S.pos -> string -> Get_type.t Lazy.t -> t =
+ fun pos t _type_of ->
+ ignore pos;
+ ignore t;
+ []
+
+ let function_ :
+ S.pos ->
+ T.function_ ->
+ (Get_type.t Lazy.t * t) list ->
+ Get_type.t Lazy.t ->
+ t =
+ fun pos f expressions _type_of ->
+ ignore pos;
+ ignore f;
+ let exprs =
+ List.fold_left ~init:[] expressions ~f:(fun acc el ->
+ List.rev_append (snd el) acc)
+ in
+ exprs
+
+ let uoperator :
+ S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t =
+ fun pos op r _type_of ->
+ ignore op;
+ ignore pos;
+ snd r
+
+ let boperator :
+ S.pos ->
+ T.boperator ->
+ Get_type.t Lazy.t * t ->
+ Get_type.t Lazy.t * t ->
+ Get_type.t Lazy.t ->
+ t =
+ fun pos op (_, r1) (_, r2) _type_of ->
+ ignore pos;
+ ignore op;
+ r1 @ r2
+end)
+
+module Instruction :
+ S.Instruction with type t' = Report.t list and type expression = Expression.t' =
+struct
+ type t = Report.t list
+ (** Internal type used in the evaluation *)
+
+ type t' = t
+
+ let v : t -> t' = Fun.id
+
+ type expression = Expression.t'
+
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun pos k exprs ->
+ ignore pos;
+ ignore k;
+ List.concat exprs
+
+ let location : S.pos -> string -> t = fun _ _ -> []
+ let comment : S.pos -> t = fun _ -> []
+ let expression : expression -> t = Fun.id
+
+ let act : S.pos -> label:expression -> t list -> t =
+ fun pos ~label instructions ->
+ ignore pos;
+ List.concat (label :: instructions)
+
+ let fold_clause : (expression, t) S.clause -> t =
+ fun (_pos1, expression, ts) -> List.concat (expression :: ts)
+
+ let if_ :
+ S.pos ->
+ (expression, t) S.clause ->
+ elifs:(expression, t) S.clause list ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun pos clause ~elifs ~else_ ->
+ ignore pos;
+
+ let init =
+ match else_ with
+ | None -> fold_clause clause
+ | Some (_, ts) -> List.rev_append (fold_clause clause) (List.concat ts)
+ in
+
+ List.fold_left elifs ~init ~f:(fun t clause ->
+ List.rev_append (fold_clause clause) t)
+
+ let assign :
+ S.pos ->
+ (S.pos, expression) S.variable ->
+ T.assignation_operator ->
+ expression ->
+ t =
+ fun pos variable op expression ->
+ ignore pos;
+ ignore op;
+ match variable.index with
+ | None -> expression
+ | Some v -> List.rev_append v expression
+end
+
+module Location = struct
+ type t = Report.t list
+ type instruction = Instruction.t'
+
+ let v = Fun.id
+
+ let location : unit -> S.pos -> instruction list -> t =
+ fun () pos intructions ->
+ ignore pos;
+ List.concat intructions
+end
diff --git a/lib/checks/nested_strings.mli b/lib/checks/nested_strings.mli
new file mode 100644
index 0000000..6446c67
--- /dev/null
+++ b/lib/checks/nested_strings.mli
@@ -0,0 +1 @@
+include Qsp_syntax.S.Analyzer
diff --git a/lib/checks/type_of.ml b/lib/checks/type_of.ml
new file mode 100644
index 0000000..70ae324
--- /dev/null
+++ b/lib/checks/type_of.ml
@@ -0,0 +1,491 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+let identifier = "type_check"
+let description = "Ensure all the expression are correctly typed"
+let is_global = false
+let active = ref true
+
+type context = unit
+
+let initialize = Fun.id
+let finalize () = []
+
+module Helper = struct
+ type argument_repr = { pos : S.pos; t : Get_type.t }
+
+ module DynType = struct
+ type nonrec t = Get_type.t -> Get_type.t
+ (** Dynamic type is a type unknown during the code.
+
+ For example, the equality operator accept either Integer or String, but
+ we expect that both sides of the equality uses the same type.*)
+
+ (** Build a new dynamic type *)
+ let t : unit -> t =
+ fun () ->
+ let stored = ref None in
+ fun t ->
+ match !stored with
+ | None ->
+ stored := Some t;
+ t
+ | Some t -> t
+ end
+
+ (** Declare an argument for a function.
+
+ - Either we already know the type and we just have to compare.
+ - Either the type shall constrained by another one
+ - Or we have a variable number of arguments. *)
+ type argument =
+ | Fixed of Get_type.type_of
+ | Dynamic of DynType.t
+ | Variable of argument
+
+ let compare :
+ ?level:Report.level ->
+ strict:bool ->
+ Get_type.type_of ->
+ argument_repr ->
+ Report.t list ->
+ Report.t list =
+ fun ?(level = Report.Warn) ~strict expected actual report ->
+ let equal =
+ match (expected, actual.t) with
+ (* Strict equality for this ones, always true *)
+ | String, Variable String
+ | String, Raw String
+ | String, Variable NumericString
+ | String, Raw NumericString
+ | Integer, Variable Integer
+ | Integer, Raw Integer
+ | NumericString, Variable NumericString
+ | NumericString, Raw NumericString
+ | Bool, Raw Bool
+ | Bool, Variable Bool
+ (* Also include the conversion between bool and integer *)
+ | Integer, Raw Bool
+ | Integer, Variable Bool
+ (* The type NumericString can be used as a generic type in input *)
+ | _, Variable NumericString
+ | NumericString, Raw String
+ | NumericString, Variable String
+ | NumericString, Raw Integer
+ | NumericString, Variable Integer ->
+ true
+ | Bool, Variable Integer
+ | Bool, Raw Integer
+ | String, Variable Integer
+ | String, Raw Bool
+ | String, Variable Bool
+ | Integer, Variable String
+ | Integer, Raw NumericString ->
+ not strict
+ (* Explicit rejected cases *)
+ | String, Raw Integer | Integer, Raw String -> false
+ | _, _ -> false
+ in
+ if equal then report
+ else
+ let result_type = match actual.t with Variable v -> v | Raw r -> r in
+ let message =
+ Format.asprintf "The type %a is expected but got %a" Get_type.pp_type_of
+ expected Get_type.pp_type_of result_type
+ in
+ Report.message level actual.pos message :: report
+
+ let rec compare_parameter :
+ strict:bool ->
+ ?level:Report.level ->
+ argument ->
+ argument_repr ->
+ Report.t list ->
+ Report.t list =
+ fun ~strict ?(level = Report.Warn) expected param report ->
+ match expected with
+ | Fixed t -> compare ~strict ~level t param report
+ | Dynamic d ->
+ let type_ = match d param.t with Raw r -> r | Variable v -> v in
+ compare ~strict ~level type_ param report
+ | Variable c -> compare_parameter ~level ~strict c param report
+
+ (** Compare the arguments one by one *)
+ let compare_args :
+ ?strict:bool ->
+ ?level:Report.level ->
+ S.pos ->
+ argument list ->
+ argument_repr list ->
+ Report.t list ->
+ Report.t list =
+ fun ?(strict = false) ?(level = Report.Warn) pos expected actuals report ->
+ let tl, report =
+ List.fold_left actuals ~init:(expected, report)
+ ~f:(fun (expected, report) param ->
+ match expected with
+ | (Variable _ as hd) :: _ ->
+ let check = compare_parameter ~strict ~level hd param report in
+ (expected, check)
+ | hd :: tl ->
+ let check = compare_parameter ~strict ~level hd param report in
+ (tl, check)
+ | [] ->
+ let msg = Report.error param.pos "Unexpected argument" in
+ ([], msg :: report))
+ in
+ match tl with
+ | [] | Variable _ :: _ -> report
+ | _ ->
+ let msg = Report.error pos "Not enougth arguments given" in
+ msg :: report
+end
+
+module TypeBuilder = Compose.Expression (Get_type)
+
+type t' = { result : Get_type.t Lazy.t; pos : S.pos }
+
+let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr =
+ fun type_of pos -> { pos; t = Lazy.force type_of }
+
+module TypedExpression = struct
+ type nonrec t' = t' * Report.t list
+ type state = { pos : S.pos }
+ type t = state * Report.t list
+
+ let v : Get_type.t Lazy.t * t -> t' =
+ fun (type_of, (t, r)) -> ({ result = type_of; pos = t.pos }, r)
+
+ (** The variable has type string when starting with a '$' *)
+ let ident :
+ (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t =
+ fun var _type_of ->
+ (* Extract the error from the index *)
+ let report =
+ match var.index with
+ | None -> []
+ | Some (_, expr) ->
+ let _, r = expr in
+ r
+ in
+ ({ pos = var.pos }, report)
+
+ let integer : S.pos -> string -> Get_type.t Lazy.t -> t =
+ fun pos value _type_of ->
+ let int_value = int_of_string_opt value in
+
+ let report =
+ match int_value with
+ | Some 0 -> []
+ | Some _ -> []
+ | None -> Report.error pos "Invalid integer value" :: []
+ in
+
+ ({ pos }, report)
+
+ let literal :
+ S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t
+ =
+ fun pos values type_of ->
+ ignore type_of;
+ let init = [] in
+ let report =
+ List.fold_left values ~init ~f:(fun report -> function
+ | T.Text _ -> report
+ | T.Expression (_, t) ->
+ let report = List.rev_append (snd t) report in
+ report)
+ in
+ ({ pos }, report)
+
+ let function_ :
+ S.pos ->
+ T.function_ ->
+ (Get_type.t Lazy.t * t) list ->
+ Get_type.t Lazy.t ->
+ t =
+ fun pos function_ params _type_of ->
+ (* Accumulate the expressions and get the results, the report is given in
+ the differents arguments, and we build a list with the type of the
+ parameters. *)
+ let types, report =
+ List.fold_left params ~init:([], [])
+ ~f:(fun (types, report) (type_of, param) ->
+ ignore type_of;
+ let t, r = param in
+ let arg = arg_of_repr type_of t.pos in
+ (arg :: types, r @ report))
+ in
+ let types = List.rev types and default = { pos } in
+
+ match function_ with
+ | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr
+ | Isplay ->
+ (default, report)
+ | Desc' | Dyneval' | Getobj' -> (default, report)
+ | Func | Func' -> (default, report)
+ | Iif | Iif' ->
+ let d = Helper.DynType.t () in
+ let expected = Helper.[ Fixed Bool; Dynamic d; Dynamic d ] in
+ let report = Helper.compare_args pos expected types report in
+ (* Extract the type for the expression *)
+ ({ pos }, report)
+ | Input | Input' ->
+ (* Input should check the result if the variable is a num and raise a
+ message in this case.*)
+ let expected = Helper.[ Fixed String ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Isnum ->
+ let expected = Helper.[ Fixed String ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Lcase | Lcase' | Ucase | Ucase' ->
+ let expected = Helper.[ Fixed String ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Len ->
+ let expected = Helper.[ Fixed NumericString ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Loc ->
+ let expected = Helper.[ Fixed String ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Max | Max' | Min | Min' ->
+ let d = Helper.DynType.t () in
+ (* All the arguments must have the same type *)
+ let expected = Helper.[ Variable (Dynamic d) ] in
+ let report = Helper.compare_args pos expected types report in
+ ({ pos }, report)
+ | Mid | Mid' ->
+ let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Msecscount -> (default, report)
+ | Rand ->
+ let expected = Helper.[ Variable (Fixed Integer) ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Replace -> (default, report)
+ | Replace' -> (default, report)
+ | Rgb -> (default, report)
+ | Rnd ->
+ (* No arg *)
+ let report = Helper.compare_args pos [] types report in
+ (default, report)
+ | Selact -> (default, report)
+ | Str | Str' ->
+ let expected = Helper.[ Variable (Fixed Integer) ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+ | Strcomp -> (default, report)
+ | Strfind -> (default, report)
+ | Strfind' -> (default, report)
+ | Strpos -> (default, report)
+ | Trim -> (default, report)
+ | Trim' -> (default, report)
+ | Val ->
+ let expected = Helper.[ Fixed NumericString ] in
+ let report = Helper.compare_args pos expected types report in
+ (default, report)
+
+ (** Unary operator like [-123] or [+'Text']*)
+ let uoperator :
+ S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t =
+ fun pos operator t1 type_of ->
+ ignore type_of;
+ let type_of, (t, report) = t1 in
+ match operator with
+ | Add -> (t, report)
+ | Neg | No ->
+ let types = [ arg_of_repr type_of t.pos ] in
+ let expected = Helper.[ Fixed Integer ] in
+ let report = Helper.compare_args pos expected types report in
+ ({ pos }, report)
+
+ let boperator :
+ S.pos ->
+ T.boperator ->
+ Get_type.t Lazy.t * t ->
+ Get_type.t Lazy.t * t ->
+ Get_type.t Lazy.t ->
+ t =
+ fun pos operator (type_1, t1) (type_2, t2) type_of ->
+ ignore type_of;
+ let t1, report1 = t1 in
+ let t2, report2 = t2 in
+
+ let report = report1 @ report2 in
+
+ let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in
+
+ match operator with
+ | T.Plus ->
+ (* We cannot really much here, because the (+) function can be used to
+ concatenate string or add numbers.
+
+ When concatenating, it’s allowed to add an integer and a number.
+ *)
+ ({ pos }, report)
+ | T.Eq | T.Neq | Lt | Gte | Lte | Gt ->
+ (* If the expression is '' or 0, we accept the comparaison as if
+ instead of raising a warning *)
+ let d = Helper.(Dynamic (DynType.t ())) in
+ let expected = [ d; d ] in
+ (* Compare and report as error if the types are incompatible. If no
+ error is reported, try in strict mode, and report as a warning. *)
+ let report =
+ match
+ Helper.compare_args ~level:Error pos expected (List.rev types)
+ report
+ with
+ | [] ->
+ Helper.compare_args ~strict:true pos expected (List.rev types)
+ report
+ | report -> report
+ in
+ ({ pos }, report)
+ | T.Mod | T.Minus | T.Product | T.Div ->
+ (* Operation over number *)
+ let expected = Helper.[ Fixed Integer; Fixed Integer ] in
+ let report = Helper.compare_args pos expected types report in
+ ({ pos }, report)
+ | T.And | T.Or ->
+ (* Operation over booleans *)
+ let expected = Helper.[ Fixed Bool; Fixed Bool ] in
+ let report = Helper.compare_args pos expected types report in
+ ({ pos }, report)
+end
+
+module Expression = TypeBuilder.Make (TypedExpression)
+
+module Instruction = struct
+ type t = Report.t list
+ type t' = Report.t list
+
+ let v : t -> t' = fun local_report -> local_report
+
+ type expression = Expression.t'
+
+ (** Call for an instruction like [GT] or [*CLR] *)
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun _pos _ expressions ->
+ List.fold_left expressions ~init:[] ~f:(fun acc a ->
+ let _, report = a in
+ (List.rev_append report) acc)
+
+ let location : S.pos -> string -> t = fun _pos _ -> []
+
+ (** Comment *)
+ let comment : S.pos -> t = fun _pos -> []
+
+ (** Raw expression *)
+ let expression : expression -> t = fun expression -> snd expression
+
+ (** Helper function used in the [if_] function. *)
+ let fold_clause : t -> (expression, t) S.clause -> t =
+ fun report (_pos, expr, instructions) ->
+ let result, r = expr in
+
+ let r2 =
+ Helper.compare ~strict:false Get_type.Bool
+ (arg_of_repr result.result result.pos)
+ []
+ in
+
+ List.fold_left instructions
+ ~init:(r @ r2 @ report)
+ ~f:(fun acc a ->
+ let report = a in
+ (List.rev_append report) acc)
+
+ let if_ :
+ S.pos ->
+ (expression, t) S.clause ->
+ elifs:(expression, t) S.clause list ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun _pos clause ~elifs ~else_ ->
+ (* Traverse the whole block recursively *)
+ let report = fold_clause [] clause in
+ let report = List.fold_left elifs ~f:fold_clause ~init:report in
+
+ match else_ with
+ | None -> report
+ | Some (_, instructions) ->
+ List.fold_left instructions ~init:report ~f:(fun acc a ->
+ let report = a in
+ (List.rev_append report) acc)
+
+ let act : S.pos -> label:expression -> t list -> t =
+ fun _pos ~label instructions ->
+ let result, report = label in
+ let report =
+ Helper.compare ~strict:false Get_type.String
+ (arg_of_repr result.result result.pos)
+ report
+ in
+
+ List.fold_left instructions ~init:report ~f:(fun acc a ->
+ let report = a in
+ (List.rev_append report) acc)
+
+ let assign :
+ S.pos ->
+ (S.pos, expression) S.variable ->
+ T.assignation_operator ->
+ expression ->
+ t =
+ fun pos variable op expression ->
+ let right_expression, report = expression in
+
+ let report' = Option.map snd variable.index |> Option.value ~default:[] in
+
+ let report = List.rev_append report' report in
+
+ match (op, Get_type.get_type (Lazy.force right_expression.result)) with
+ | T.Eq', Get_type.Integer ->
+ (* Assigning an intger is allowed in a string variable, but raise a
+ warning. *)
+ let var_type = Lazy.from_val (Get_type.ident variable) in
+ let op1 = arg_of_repr var_type variable.pos in
+ let expected = Helper.[ Fixed Integer ] in
+ Helper.compare_args ~strict:true ~level:Report.Warn pos expected [ op1 ]
+ report
+ | _, _ -> (
+ let var_type = Lazy.from_val (Get_type.ident variable) in
+ let op1 = arg_of_repr var_type variable.pos in
+ let op2 = arg_of_repr right_expression.result right_expression.pos in
+
+ let d = Helper.DynType.t () in
+ (* Every part of the assignation should be the same type *)
+ let expected = Helper.[ Dynamic d; Dynamic d ] in
+
+ match
+ Helper.compare_args ~strict:false ~level:Report.Error pos expected
+ [ op1; op2 ] []
+ with
+ | [] ->
+ Helper.compare_args ~strict:true ~level:Report.Warn pos expected
+ [ op1; op2 ] report
+ | reports -> reports @ report)
+end
+
+module Location = struct
+ type t = Report.t list
+ type instruction = Instruction.t'
+
+ let v = Fun.id
+
+ let location : unit -> S.pos -> instruction list -> t =
+ fun () _pos instructions ->
+ let report =
+ List.fold_left instructions ~init:[] ~f:(fun report instruction ->
+ let report' = instruction in
+ report' @ report)
+ in
+ report
+end
diff --git a/lib/checks/type_of.mli b/lib/checks/type_of.mli
new file mode 100644
index 0000000..de0f8f9
--- /dev/null
+++ b/lib/checks/type_of.mli
@@ -0,0 +1,7 @@
+include Qsp_syntax.S.Analyzer
+(** The module [type_of] populate the report with differents inconsistency
+ errors in the types.
+
+ - Assigning a [string] value in an [integer] variable
+ - Comparing a [string] with an [integer]
+ - Giving the wrong type in the argument for a function and so one. *)
diff --git a/lib/checks/write_only.ml b/lib/checks/write_only.ml
new file mode 100644
index 0000000..8363703
--- /dev/null
+++ b/lib/checks/write_only.ml
@@ -0,0 +1,220 @@
+(** Check all the write_only variables *)
+
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+(** Identifier for the module *)
+let identifier = "write_only"
+
+(** Short description*)
+let description = "Check variables never read"
+
+(** Is the test active or not *)
+let active = ref false
+
+let is_global = true
+
+module Key = struct
+ type t = string
+
+ let equal = String.equal
+ let hash = Hashtbl.hash
+ let compare = String.compare
+end
+
+module StringMap = Hashtbl.Make (Key)
+module Set = Set.Make (Key)
+
+type data = { write : bool; read : bool; position : S.pos list }
+type context = (string * data) StringMap.t
+
+let initialize () = StringMap.create 16
+
+let keywords =
+ [
+ "BACKIMAGE";
+ "$BACKIMAGE";
+ "BCOLOR";
+ "DEBUG";
+ "DISABLESCROLL";
+ "DISABLESUBEX";
+ "FCOLOR";
+ "$FNAME";
+ "FSIZE";
+ "GC";
+ "LCOLOR";
+ "NOSAVE";
+ ]
+ |> Set.of_list
+
+let set_readed :
+ ?update_only:bool -> S.pos -> string -> string -> context -> unit =
+ fun ?(update_only = false) pos identifier filename map ->
+ if not (Set.mem identifier keywords) then
+ match (update_only, StringMap.find_opt map identifier) with
+ | false, None ->
+ StringMap.add map identifier
+ (filename, { write = false; read = true; position = [] })
+ | _, Some (filename, v) ->
+ StringMap.replace map identifier
+ (filename, { v with read = true; position = pos :: v.position })
+ | true, None -> ()
+
+let set_write : S.pos -> string -> string -> context -> unit =
+ fun pos identifier filename map ->
+ if not (Set.mem identifier keywords) then
+ match StringMap.find_opt map identifier with
+ | None ->
+ StringMap.add map identifier
+ (filename, { write = true; read = false; position = pos :: [] })
+ | Some (filename, v) ->
+ StringMap.replace map identifier
+ (filename, { v with write = true; position = pos :: v.position })
+
+module Expression = struct
+ type t = string -> context -> unit
+
+ let v : t -> t = Fun.id
+
+ include Default.Expression (struct
+ type nonrec t = t
+
+ let default _ map = ignore map
+ end)
+
+ let ident : (S.pos, t) S.variable -> t =
+ fun variable filename map ->
+ (* Update the map and set the read flag *)
+ set_readed variable.pos variable.name filename map
+
+ let literal : S.pos -> t T.literal list -> t =
+ fun pos l filename map ->
+ List.iter l ~f:(function
+ | T.Text t ->
+ set_readed pos ~update_only:true (String.uppercase_ascii t) filename
+ map
+ | T.Expression exprs ->
+ (* When the string contains an expression evaluate it *)
+ exprs filename map)
+
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun _ _ exprs filename map -> List.iter ~f:(fun v -> v filename map) exprs
+
+ let uoperator : S.pos -> T.uoperator -> t -> t = fun _ _ t map -> t map
+
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun _ _ t1 t2 filename map ->
+ t1 filename map;
+ t2 filename map
+end
+
+module Instruction = struct
+ type t = Expression.t
+ (** Internal type used in the evaluation *)
+
+ type t' = t
+
+ let v : t -> t' = Fun.id
+
+ type expression = Expression.t
+
+ let location : S.pos -> string -> t = fun _pos _ _ _ -> ()
+
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun _ op exprs filename map ->
+ match op with
+ | T.KillVar ->
+ (* Killing a variable does not count as reading it *)
+ ()
+ | _ -> List.iter ~f:(fun v -> v filename map) exprs
+
+ let comment : S.pos -> t = fun _ _ _ -> ()
+ let expression : expression -> t = fun expression map -> expression map
+
+ let fold_clause : (expression, t) S.clause -> t =
+ fun clause filename map ->
+ let _, expr, exprs = clause in
+ let () = expr filename map in
+ let () = List.iter ~f:(fun v -> v filename map) exprs in
+ ()
+
+ let if_ :
+ S.pos ->
+ (expression, t) S.clause ->
+ elifs:(expression, t) S.clause list ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun pos clauses ~elifs ~else_ filename map ->
+ ignore pos;
+ let () = fold_clause clauses filename map in
+ let () = List.iter ~f:(fun v -> fold_clause v filename map) elifs in
+ Option.iter
+ (fun (_, exprs) -> List.iter exprs ~f:(fun v -> v filename map))
+ else_;
+ ()
+
+ let act : S.pos -> label:expression -> t list -> t =
+ fun pos ~label exprs filename map ->
+ ignore pos;
+ ignore label;
+ List.iter ~f:(fun v -> v filename map) exprs
+
+ let assign :
+ S.pos ->
+ (S.pos, expression) S.variable ->
+ T.assignation_operator ->
+ expression ->
+ t =
+ fun pos variable op expr filename map ->
+ ignore op;
+ ignore expr;
+ Option.iter (fun v -> v filename map) variable.index;
+ expr filename map;
+ set_write pos variable.name filename map
+end
+
+module Location = struct
+ type t = unit
+ type instruction = string -> context -> unit
+
+ let v : t -> Report.t list = fun _ -> []
+
+ let location : context -> S.pos -> instruction list -> t =
+ fun context pos instructions ->
+ let file_name = (snd pos).Lexing.pos_fname in
+ ignore pos;
+ ignore context;
+ let () = List.iter ~f:(fun v -> v file_name context) instructions in
+ ()
+end
+
+(** Extract the results from the whole parsing *)
+let finalize : context -> (string * Report.t) list =
+ fun map ->
+ let () =
+ StringMap.filter_map_inplace
+ (fun _ (loc, value) ->
+ match value.read && value.write with
+ | true -> None
+ | false -> Some (loc, value))
+ map
+ in
+
+ let report =
+ StringMap.fold
+ (fun ident (loc, value) report ->
+ match value.read with
+ | false ->
+ List.fold_left value.position ~init:report ~f:(fun report pos ->
+ let msg =
+ Report.debug pos
+ (String.concat ~sep:" "
+ [ "The variable"; ident; "is never read" ])
+ in
+ (loc, msg) :: report)
+ | true -> report)
+ map []
+ in
+ report
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 10:00:48 +0000