lambda.ml 4.64 KB
Newer Older
1 2 3 4 5
(* Representation of programs used by the runtime evaluator.
   Similar to the typed abstract syntax tree representation, but:
   - the pattern matching is compiled;
   - the identifiers locations are resolved. *)

6 7 8
open Ident

type var_loc =
9 10
  | Local of int
      (* Slot in the table of locals *)
11
  | Env of int
12 13 14 15 16 17
      (* Slot in the environment *)
  | Ext of Compunit.t * int 
      (* Global slot from a given compilation unit *)
      (* If pos < 0, the first arg is the value *)
  | External of Compunit.t * int 
      (* OCaml External *)
18
      (* If pos < 0, the first arg is the value *)
19
  | Builtin of string
20 21 22
      (* OCaml external embedded in the runtime *)
  | Global of int 
      (* Only for the toplevel *)
23 24
  | Dummy

25 26
type iface = (Types.descr * Types.descr) list

27
type sigma = 
28
  | Identity (* this is basically as Types.Tallying.CS.sat *)
29
  | List of Types.Subst.t list
30
  | Comp of (sigma * sigma)
31
  | Sel of (var_loc * iface * sigma) 
32

33 34
(* only TVar (polymorphic type variable) and Abstraction have
 * a sigma annotation *)
35 36
type expr = 
  | Var of var_loc
Pietro Abate's avatar
Pietro Abate committed
37
  | TVar of (var_loc * sigma)
38
  | Apply of expr * expr
Pietro Abate's avatar
Pietro Abate committed
39
  | Abstraction of var_loc array * iface * branches * int
40 41
  | PolyAbstraction of var_loc array * iface * branches * int * sigma
      (* environment, interface, branches, size of locals, sigma *)
42 43
  | Check of expr * Auto_pat.state
  | Const of Value.t
44 45 46 47
  | Pair of expr * expr
  | Xml of expr * expr * expr
  | XmlNs of expr * expr * expr * Ns.table
  | Record of expr Imap.t
48 49 50 51 52
  | String of U.uindex * U.uindex * U.t * expr
  | Match of expr * branches
  | Map of expr * branches
  | Transform of expr * branches
  | Xtrans of expr * branches
53
  | Try of expr * branches
54
  | Validate of expr * Schema_validator.t
55 56
  | RemoveField of expr * label
  | Dot of expr * label
57
  | Ref of expr * Types.Node.t
58 59
  | Op of string * expr list  
  | OpResolved of (Value.t list -> Value.t) * expr list
60
  | NsTable of Ns.table * expr
61 62

and branches = {
63
  brs_accept_chars: bool;
64 65 66
  brs_disp: Auto_pat.state;
  brs_rhs: expr Auto_pat.rhs array;
  brs_stack_pos: int
67 68
}

69
type code_item =
70 71 72 73 74
  | Eval of expr * int
      (* expression, size of locals *)
  | LetDecls of expr * int * Auto_pat.state * int
      (* expression, size of locals, dispatcher, number of globals to set *)
  | LetDecl of expr * int
75 76

type code = code_item list
77 78 79 80 81 82 83 84 85 86 87 88 89

module Print = struct

  let pp_vloc ppf = function
    | Local(i) -> Format.fprintf ppf "Local(%d)" i
    | Env(i) -> Format.fprintf ppf "Env(%d)" i
    | Ext(_, i) -> Format.fprintf ppf "Ext(?, %d)" i
    | External(_, i) -> Format.fprintf ppf "External(?, %d)" i
    | Builtin(s) -> Format.fprintf ppf "Builtin(%s)" s
    | Global(i) -> Format.fprintf ppf "Global(%d)" i
    | Dummy -> Format.fprintf ppf "Dummy"

  let pp_vloc_array ppf a =
90
    Utils.pp_list pp_vloc ppf (Array.to_list a)
91 92 93 94 95 96 97

  let pp_binding ppf (id, name) value =
    Format.fprintf ppf "((%d,%s),%a)\n"
      (Upool.int id)
      (Encodings.Utf8.to_string name)
      pp_vloc value

98
  let rec pp_sigma ppf =
99
    let pp_aux ppf =
100 101
      Utils.pp_list (fun ppf (t1,t2) ->
        Format.fprintf ppf "(%a -> %a)"
102 103
          Types.Print.pp_type t1
          Types.Print.pp_type t2
104 105 106
      ) ppf
    in
    function
107
      |List ll -> Type_tallying.pp_sl ppf ll
108 109
      |Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
      |Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_sigma s
110 111
      |Identity -> Format.fprintf ppf "Id"

112
  and pp ppf = function
113
    | Var v -> Format.fprintf ppf "Var(%a)" pp_vloc v
114 115
    | TVar (v,sigma) -> Format.fprintf ppf "TVar(%a,%a)" pp_vloc v pp_sigma sigma
    | Apply (e1,e2) -> Format.fprintf ppf "Apply(%a,%a)" pp e1 pp e2
116
    | PolyAbstraction (va, l, b, i, sigma) ->
117
      Format.fprintf ppf "PolyAbstraction(%a,,%a,,%a)" pp_vloc_array va pp_lbranches b pp_sigma sigma
118 119 120
    | Abstraction (va, l, b, i) ->
      Format.fprintf ppf "Abstraction(%a,,%a,,)" pp_vloc_array va pp_lbranches b
    | Check(_) -> Format.fprintf ppf "Check"
121 122
    | Const(v) -> Format.fprintf ppf "Const(%a)" Value.Print.pp v
    | Pair(e1, e2) -> Format.fprintf ppf "Pair(%a, %a)" pp e1 pp e2
123
    | String(_) -> Format.fprintf ppf "String"
124 125
    | Match(e, brs) -> Format.fprintf ppf "Match(%a, %a)" pp e pp_lbranches brs
    | Op(str, le) -> Format.fprintf ppf "Op(%s, (%a))" str (Utils.pp_list pp) le
126 127 128 129 130 131
    | _ -> ()

  and pp_lbranches ppf brs =
    Format.fprintf ppf "{accept_chars=%b; brs_disp=<disp>; brs_rhs=[| %a |]; brs_stack_pos=%d}" brs.brs_accept_chars pp_patrhs brs.brs_rhs brs.brs_stack_pos

  and pp_patrhs ppf arr =
132
    Array.iter (function | Auto_pat.Match(i, e) -> Format.fprintf ppf "(%d, %a)" i pp e | _ -> ()) arr
133

134
  let string_of_lambda = Utils.string_of_formatter pp
135 136

end