1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
open Lang

module Make (M : sig
  val get_old_name : string -> string

  module Error : sig
    exception Unused_variable of string

    exception Inline_lack of string
  end
end) =
struct
  let usage = Hashtbl.create 512

  let inlinable = Hashtbl.create 512

  let const = function
    | Literal _ ->
        ()
    | Var id ->
        incr (Hashtbl.find usage id)

  let introduce_id is_inlinable id =
    Hashtbl.add usage id (ref 0) ;
    if is_inlinable then Hashtbl.add inlinable id ()

  let rec expr = function
    | Const c ->
        const c
    | Bind (id, e1, e2) ->
        introduce_id true id ; expr e1 ; expr e2
    | Abstract (_, id, e) ->
        introduce_id false id ; expr e
    | Apply (e1, e2) ->
        expr e1 ; expr e2
    | If_then_else (cond, e1, e2) ->
        expr cond ; expr e1 ; expr e2
    | Match (_origin, match_expr, cases) ->
        expr match_expr ;
        List.iter (fun (_, e) -> expr e) cases

  let check_unused () =
    Hashtbl.iter
      (fun k v ->
        let n = !v in
        let old_name = M.get_old_name k in
        if n = 0 then raise @@ M.Error.Unused_variable old_name
        else if n = 1 && Hashtbl.mem inlinable k then
          raise @@ M.Error.Inline_lack old_name)
      usage

  let expr e = expr e ; check_unused ()
end