compile.ml 2.84 KB
Newer Older
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
open Printf
open Parse
open Lambda
open Auto_pat
open Value

let page_size = 1000

type env =
{
  parent: env option; (* None: toplevel *)
  map: (string, int) Hashtbl.t;
  locals: var_loc array;
  max_size: int;
  actual_size: int;
  global_size: int
}

let mk_env ?parent:(p=None) ?max_size:(s=page_size) ?map:(m=Hashtbl.create s)
    ?locals:(l=Array.make s Dummy) actual_size global_size =
  { parent=p; map=m; locals=l; max_size=s; actual_size=actual_size;
    global_size=global_size }

let parse_to_lambda expr = (* TODO: Replace dummy_branches *)
  let rec _parse_to_lambda env expr =
    let dummy_state = { uid=0; arity=[||]; actions=AIgnore(0,[||],0);
			fail_code=0; expected_type="" } in
    let dummy_branches = { brs_accept_chars=true; brs_disp=dummy_state;
			   brs_rhs=[||]; brs_stack_pos=0 } in
    match expr with
      | Parse.Apply(e1, e2) ->
	Apply(_parse_to_lambda env e1, _parse_to_lambda env e2)
      | Abstract(fname, interface, body) ->
	let params, nbrparams =
	  let rec fill_params params res nbr = match params with
	    | el :: rest ->
	      let curr = [|Local(0)|] in (* TODO: Not supposed to be 0 *)
	      fill_params rest (Array.append res curr) (nbr + 1)
	    | [] -> res, nbr
	  in
	  fill_params interface [||] 0
	in
	Abstraction(params, [], dummy_branches, nbrparams, true, List([[]]))
      | Var(vname) -> Var(Local(0)) (* TODO: Not supposed to be 0 *)
      | 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,
	       Const(Atom(nil_atom)))
      | Pair(e1, e2) -> Pair(_parse_to_lambda env e1, _parse_to_lambda env e2)
      | Match(e, branches) ->
	Match(_parse_to_lambda env e, dummy_branches)
      | Let(x, e1, e2) -> (* TODO: Define the "_" *)
	let map = Hashtbl.create page_size in
	let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
	  ~locals:[|Local(env.global_size)|] 1 (env.global_size + 1) in
	Hashtbl.add map x 0;
	Apply(_parse_to_lambda new_env (Abstract("_", [x], e2)),
	      _parse_to_lambda env e1)
  in
  _parse_to_lambda (mk_env 0 0) expr

let rec print_value v = match v with
  | Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
    print_value v2; printf ")"
  | Xml(_,_,_) -> printf "Xml"
  | XmlNs(_,_,_,_) -> printf "XmlNs"
  | Record(_) -> printf "Record"
  | Atom(_) -> printf "Atom"
  | Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
  | Char(i) -> printf "Char(%d)" i
  | Abstraction(_, _) -> printf "Abstraction()"
  | Abstract((name, _)) -> printf "Abstract(%s)" name
  | String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
    print_value v
  | String_utf8(_,_,s,_) -> printf "String(%s)" s
  | Concat(v1, v2) -> printf "Concat("; print_value v1; printf ", ";
    print_value v2; printf ")"
  | Absent -> printf "Absent"