compile.ml 3.11 KB
Newer Older
1
2
3
4
5
6
7
8
open Printf
open Parse
open Lambda
open Auto_pat

let page_size = 1000

type env =
9
10
11
12
13
14
15
    {
      parent: env option; (* None: toplevel *)
      map: (string, int) Hashtbl.t;
      max_size: int;
      actual_size: int;
      global_size: int
    }
16
17

let mk_env ?parent:(p=None) ?max_size:(s=page_size) ?map:(m=Hashtbl.create s)
18
19
    a_size g_size =
  { parent=p; map=m; max_size=s; actual_size=a_size; global_size=g_size }
20

21
22
23
24
25
26
let rec env_find env el =
  try Hashtbl.find env.map el with Not_found -> match env.parent with
    | Some p -> env_find p el
    | None -> raise Not_found

let parse_to_lambda expr =
27
28
29
30
31
  let rec _parse_to_lambda env expr =
    match expr with
      | Parse.Apply(e1, e2) ->
	Apply(_parse_to_lambda env e1, _parse_to_lambda env e2)
      | Abstract(fname, interface, body) ->
32
33
	let map = Hashtbl.create page_size in
	Hashtbl.add map fname 0;
34
35
	let params, nbrparams =
	  let rec fill_params params res nbr = match params with
36
	    | el :: rest -> Hashtbl.add map el nbr;
37
	      let curr = [|Local(env.global_size + nbr)|] in
38
39
40
	      fill_params rest (Array.append res curr) (nbr + 1)
	    | [] -> res, nbr
	  in
41
	  fill_params interface [||] 1
42
	in
43
	let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
Julien Lopez's avatar
Julien Lopez committed
44
	  nbrparams (env.global_size + nbrparams) in
45
46
	let brs = compile_func_body new_env body in
	Abstraction(params, [], brs, nbrparams, true, List [[]])
47
48
      | Var(vname) -> (try let index = env_find env vname in Var(Local(index))
	with Not_found -> raise Not_found)
49
50
51
52
53
      | Int(i) -> Const(Value.Integer(Intervals.V.from_int i))
      | String(s) ->
	let s = Ident.U.mk s in
	let nil_atom = Atoms.V.mk_ascii "nil" in
	String(Ident.U.start_index s, Ident.U.end_index s, s,
54
	       Const(Value.Atom(nil_atom)))
55
56
      | Pair(e1, e2) -> Pair(_parse_to_lambda env e1, _parse_to_lambda env e2)
      | Match(e, branches) ->
57
	Match(_parse_to_lambda env e, compile_branches env branches)
58
59
60
      | Let(x, e1, e2) -> (* TODO: Define the "_" *)
	let map = Hashtbl.create page_size in
	Hashtbl.add map x 0;
61
62
	let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
	  1 (env.global_size + 1) in
63
64
	Apply(_parse_to_lambda new_env (Abstract("_", [x], e2)),
	      _parse_to_lambda env e1)
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

  (* TODO: Fix this function *)
  and compile_func_body env body =
    let dummy_state = { uid=0; arity=[||]; actions=AIgnore(0,[||],0);
			fail_code=0; expected_type="" } in
    let body = _parse_to_lambda env body in
    { brs_accept_chars=true; brs_disp=dummy_state;
      brs_rhs=[|Auto_pat.Match (0, body)|]; brs_stack_pos=env.global_size }

  (* TODO: Fix this function *)
  and compile_branches env brs =
    let dummy_state = { uid=0; arity=[||]; actions=AIgnore(0,[||],0);
			fail_code=0; expected_type="" } in
    let rec aux env brs rhs uid =
      match brs with
	(* match ? with | m & t -> e | ... *)
	| (m, t, e) :: rest ->
	  let e = _parse_to_lambda env e in
	  aux env rest (Array.append rhs [|Auto_pat.Match (uid, e)|]) (uid + 1)
	| [] -> dummy_state, rhs
    in
    let (state, rhs) = aux env brs [||] 0 in
    { brs_accept_chars=true; brs_disp=state; brs_rhs=rhs;
      brs_stack_pos=env.global_size }
89
90
  in
  _parse_to_lambda (mk_env 0 0) expr