[TESTS][EVAL] Environment management done; remains only to define branches

tests/eval/src/compile.ml

@@ -2,7 +2,6 @@ open Printf
 open Parse
 open Lambda
 open Auto_pat
-open Value
 
 let page_size = 1000
 
@@ -10,71 +9,65 @@ 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 }
+    a_size g_size =
+  { parent=p; map=m; max_size=s; actual_size=a_size; global_size=g_size }
 
-let parse_to_lambda expr = (* TODO: Replace dummy_branches *)
+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 compile_branches env body = (* TODO: Replace dummy_branches *)
+  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
+  dummy_branches
+
+let parse_to_lambda expr =
   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 map = Hashtbl.create page_size in
+	Hashtbl.add map fname 0;
 	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 *)
+	    | el :: rest -> Hashtbl.add map el nbr;
+	      let curr = [|Local(nbr)|] in
 	      fill_params rest (Array.append res curr) (nbr + 1)
 	    | [] -> res, nbr
 	  in
-	  fill_params interface [||] 0
+	  fill_params interface [||] 1
 	in
-	Abstraction(params, [], dummy_branches, nbrparams, true, List([[]]))
-      | Var(vname) -> Var(Local(0)) (* TODO: Not supposed to be 0 *)
+	let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
+	  nbrparams (env.global_size + nbrparams + 1) in
+	Abstraction(params, [], compile_branches new_env body, nbrparams, true,
+		    List [[]])
+      | Var(vname) -> (try let index = env_find env vname in Var(Local(index))
+	with Not_found -> raise Not_found)
       | 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)))
+	       Const(Value.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)
+	Match(_parse_to_lambda env e, compile_branches env 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;
+	let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
+	  1 (env.global_size + 1) in
 	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"

tests/eval/src/compile.mli

+val parse_to_lambda : Parse.expr -> Lambda.expr

tests/eval/src/main.ml

 open Printf
 open Parse
+open Value
 
 let load_file f =
   let ic = open_in f in
@@ -9,13 +10,31 @@ let load_file f =
   close_in ic;
   s
 
+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"
+
 let str = if Array.length Sys.argv > 1 then load_file Sys.argv.(1)
   else (*"let z = 3 in fun firsts x y -> match x,y with
 | (a,_),(b,_) -> a,b (* This (* is (* a nested *) *) comment *)
-| _ -> x . z (* That doesn't make any sense *)"*) "\"The cake is a lie\"" in
+| _ -> x . z (* That doesn't make any sense *)"*) "let x = 2 in x" in
 let expr = ExprParser.of_string str in
 (*printf "Original: %s\nExpr: " str;
 print_expr expr;
 printf "\nResult: %s\n" (expr_to_string expr);*)
 let evalexpr = Eval.expr (Compile.parse_to_lambda expr) 100 in
-Compile.print_value evalexpr; printf "\n"
+print_value evalexpr; printf "\n"

tests/eval/src/parse.ml

@@ -8,7 +8,7 @@ type expr =
   | String of string
   | Pair of expr * expr
   | Match of expr * (expr * string option * expr) list
-  | Let of string * expr * expr;;
+  | Let of string * expr * expr
 
 module ExprParser = struct
   open Camlp4.PreCast
@@ -55,9 +55,7 @@ module ExprParser = struct
     END;;
 
   let of_string s = Gram.parse_string exp_eoi (Loc.mk "<string>") s
-  let os = of_string
-
-end;;
+end
 
 exception InvalidBranches;;
 

tests/eval/src/parse.mli

+type expr =
+  | Apply of expr * expr
+  | Abstract of string * string list * expr
+  | Var of string
+  | Int of int
+  | String of string
+  | Pair of expr * expr
+  | Match of expr * (expr * string option * expr) list
+  | Let of string * expr * expr
+
+module ExprParser : sig
+
+  val of_string : string -> expr
+end
+
+val print_expr : expr -> unit
+val expr_to_string : expr -> string