src/env.ml

  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
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106

(* Environment *)

module SMap = Map.Make (String)

type locals = string SMap.t

type 'a t =
  { values : 'a ref SMap.t
  ; globals : string SMap.t
  ; locals : locals
  ; loaded_packages : 'a list SMap.t
  }

(* hack: "unit option *" to get the right exception format (Ast.location option * string) *)
exception Env_error of unit option * string

let error message = raise (Env_error (None, message))

let fresh =
  let count = ref ~-1 in
  fun () ->
    incr count;
    Format.sprintf "v%d" !count

let add_global n default_value env =
  let default_value = ref default_value in
  let fresh_name = fresh () in
  let values = SMap.add fresh_name default_value env.values in
  let globals = SMap.add n fresh_name env.globals in
  (fresh_name, { env with values; globals })

let add_global_force n v env =
  let v = ref v in
  let values = SMap.add n v env.values in
  let globals = SMap.add n n env.globals in
  { env with values; globals }

let add_local n default_value env =
  let default_value = ref default_value in
  let fresh_name = fresh () in
  let values = SMap.add fresh_name default_value env.values in
  let locals = SMap.add n fresh_name env.locals in
  (fresh_name, { env with values; locals })

let add_local_force n v env =
  let v = ref v in
  let values = SMap.add n v env.values in
  let locals = SMap.add n n env.locals in
  { env with values; locals }

let get_name n default_value env =
  let default_value = ref default_value in
  match SMap.find_opt n env.locals with
  | Some n -> (n, env)
  | None -> (
    match SMap.find_opt n env.globals with
    | Some n -> (n, env)
    | None -> add_global n !default_value env )

let get_value n env =
  match SMap.find_opt n env.values with
  | None ->
    error (Format.sprintf "name: %s not found in get_value env.values" n)
  | Some v -> Ok !v

let update_value n v env =
  let v = ref v in
  match SMap.find_opt n env.values with
  | None ->
    error (Format.sprintf "name: %s not found in update_value env.values" n)
  | Some value ->
    value := !v;
    Ok ()

let add_value n v env =
  let v = ref v in
  match SMap.find_opt n env.values with
  | None ->
    error (Format.sprintf "name: %s not found in add_value env.values" n)
  | Some _ ->
    let values = SMap.add n v env.values in
    Ok { env with values }

let get_locals env = env.locals

let with_locals env locals = { env with locals }

let add_package n vl env =
  let loaded_packages = SMap.add n vl env.loaded_packages in
  { env with loaded_packages }

let get_package n env =
  match SMap.find_opt n env.loaded_packages with
  | None -> Error (None, Format.sprintf "package name: %s not loaded" n)
  | Some vl -> Ok vl

let is_package_loaded n env =
  let find_opt = SMap.find_opt n env.loaded_packages in
  Option.is_some find_opt

let empty () =
  let values = SMap.empty in
  let globals = SMap.empty in
  let locals = SMap.empty in
  let loaded_packages = SMap.empty in
  { values; globals; locals; loaded_packages }