[TESTS][LAMBDA] Split compute and parse (needed to create the environment)

tests/lambda/Makefile

@@ -15,14 +15,15 @@ INEXTFILES	= misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
  types/externals.mli types/externals.ml typing/typer.ml\
  runtime/run_dispatch.ml runtime/explain.ml schema/schema_pcre.ml\
  schema/schema_xml.mli schema/schema_xml.ml schema/schema_common.mli\
- schema/schema_common.ml runtime/eval.mli runtime/eval.ml compile/compile.ml\
- types/compunit.mli types/compunit.ml types/var.ml types/boolVar.ml\
- misc/imap.ml types/atoms.ml types/intervals.ml types/chars.mli types/chars.ml\
- misc/bool.mli misc/bool.ml types/types.mli misc/stats.mli misc/stats.ml\
- types/normal.mli types/normal.ml misc/pretty.mli misc/pretty.ml\
- types/types.ml compile/auto_pat.mli runtime/value.mli runtime/value.ml\
- schema/schema_types.mli schema/schema_validator.mli schema/schema_builtin.mli\
- schema/schema_builtin.ml schema/schema_validator.ml compile/lambda.ml
+ schema/schema_common.ml runtime/eval.mli runtime/eval.ml compile/compile.mli\
+ compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml\
+ types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml\
+ types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli\
+ misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli\
+ misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli\
+ runtime/value.ml schema/schema_types.mli schema/schema_validator.mli\
+ schema/schema_builtin.mli schema/schema_builtin.ml schema/schema_validator.ml\
+ compile/lambda.ml
 EXTFILES	= $(INEXTFILES:%=$(ROOTDIR)/%)
 
 RM		?= rm -f

tests/lambda/_tags

 <src>: include
-<src/parse*>:  pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
-<src/main*>:  pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
+<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
+<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
+<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
 
 <src/externals>: include
-<src/externals/schema_*>: package(pcre, netcgi2, unix, netsys, str)
+<src/externals/schema_*>: package(pcre, netcgi2)
 <src/externals/cduce_loc*>: package(ulex), syntax(camlp4o)

tests/lambda/src/compute.ml

+open Parse
+open Typed
+open Camlp4.PreCast
+
+let rec to_typed expr =
+  let env = Compile.empty_toplevel in match expr with
+    | Parse.Apply (loc, e1, e2) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      env, { exp_loc=loc; exp_typ=Types.any;
+	     exp_descr=Apply(snd (to_typed e1), snd (to_typed e2)) }
+    | Abstr (loc, fun_name, params, return_type, body) ->
+      env, parse_abstr loc fun_name params return_type body
+    | Match (loc, e, b) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      let b = parse_branches b [] in
+      let brs = { br_typ=Types.any; br_accept=Types.any; br_branches=b } in
+      env, { exp_loc=loc; exp_typ=Types.any;
+	     exp_descr=Match(snd (to_typed e), brs) }
+    | Pair (loc, e1, e2) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      env, { exp_loc=loc; exp_typ=Types.any;
+	     exp_descr=Pair(snd(to_typed e1), snd(to_typed e2)) }
+    | Var (loc, vname) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      env, { exp_loc=loc; exp_typ=Types.any; exp_descr=Var(0, vname) }
+    | Int (loc, i) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      let i = Big_int.big_int_of_int i in
+      env, { exp_loc=loc; exp_typ=Types.any; exp_descr=Cst(Types.Integer i) }
+    | String (loc, s) ->
+      let loc = `File(Loc.file_name loc),
+	Loc.start_off loc - Loc.start_bol loc,
+	Loc.stop_off loc - Loc.start_bol loc in
+      let s = Types.String (0, (String.length s) - 1, s,
+			    Types.Integer (Big_int.big_int_of_int 0)) in
+      env, { exp_loc=loc; exp_typ=Types.any; exp_descr=Cst s }
+
+and parse_abstr loc fun_name params return_type body =
+  let loc = `File(Loc.file_name loc),
+    Loc.start_off loc - Loc.start_bol loc,
+    Loc.stop_off loc - Loc.start_bol loc in
+  let node = Patterns.make [] in
+  let brloc = get_loc body in
+  let brloc = `File(Loc.file_name brloc),
+    Loc.start_off brloc - Loc.start_bol brloc,
+    Loc.stop_off brloc - Loc.start_bol brloc in
+  let br = { br_loc=brloc; br_used=true; br_ghost=false;
+             br_vars_empty=[]; br_pat=node;
+	     br_body=snd(to_typed body) } in
+  let brs = { br_typ=Types.any; br_accept=Types.any;
+	      br_branches=[br] } in
+  let iface = parse_iface params [] in
+  { exp_loc=loc; exp_typ=Types.any;
+    exp_descr=Abstraction({ fun_name=Some (0, fun_name); fun_iface=iface;
+			    fun_body=brs; fun_typ=Types.any; fun_fv=[] }) }
+
+and parse_iface params res = match params with
+  | _ :: rest -> parse_iface rest (res @ [Types.any, Types.any])
+  | [] -> res
+
+and parse_branches brs res = match brs with
+  | (loc, p, e) :: rest ->
+    let loc = `File(Loc.file_name loc),
+      Loc.start_off loc - Loc.start_bol loc,
+      Loc.stop_off loc - Loc.start_bol loc in
+    let node = Patterns.make [] in
+    let b = { br_loc=loc; br_used=true; br_ghost=false; br_vars_empty=[];
+	      br_pat=node; br_body=snd(to_typed e)} in
+    parse_branches rest (res @ [b])
+  | [] -> res

tests/lambda/src/compute.mli

+val to_typed : Parse.expr -> Compile.env * Typed.texpr

tests/lambda/src/main.ml

 open Printf
 open Parse
-open Compile
 open Value
 open Camlp4.PreCast
 
@@ -36,8 +35,8 @@ let str, file =
 in
 try
   let expr = ExprParser.of_string str file in
-  let lambdaexpr = compile (mk None) expr in
-  let evalexpr = Eval.expr lambdaexpr 100 in
+  let env, texpr = Compute.to_typed expr in
+  let evalexpr = Compile.compile_eval_expr env texpr in
   print_value evalexpr; printf "\n"
 with
   | Loc.Exc_located (loc, exn) ->

tests/lambda/src/parse.ml

 open Printf
-open Typed
-open Patterns
 open Camlp4.PreCast
 
+type expr =
+  | Apply of Loc.t * expr * expr
+  | Abstr of Loc.t * fun_name * params * ptype * expr
+  | Match of Loc.t * expr * branches
+  | Pair of Loc.t * expr * expr
+  | Var of Loc.t * string
+  | Int of Loc.t * int
+  | String of Loc.t * string
+and fun_name = string
+and params = (Loc.t * string * ptype) list
+and branches = (Loc.t * match_value * expr) list
+and match_value =
+  | MPair of Loc.t * match_value * match_value
+  | MVar of Loc.t * string * ptype
+  | MInt of Loc.t * int
+  | MString of Loc.t * string
+and ptype = string
+
 module ExprParser = struct
 
   let exp_eoi = Gram.Entry.mk "exp_eoi"
@@ -15,101 +31,41 @@ module ExprParser = struct
     expression:
       [
 	"abstr" RIGHTA
-	  [ "fun"; x = LIDENT; p = LIST1 param; ":"; t = UIDENT; "->"; e = SELF ->
-	  let loc = `File(Loc.file_name _loc),
-	    Loc.start_off _loc - Loc.start_bol _loc,
-	    Loc.stop_off _loc - Loc.start_bol _loc in
-	  let node = Patterns.make [] in
-	  let br = { br_loc=e.exp_loc; br_used=true; br_ghost=false;
-                     br_vars_empty=[]; br_pat=node; br_body=e } in
-          let brs = { br_typ=Types.any; br_accept=Types.any;
-		      br_branches=[br] } in
-	  { exp_loc=loc; exp_typ=Types.any;
-            exp_descr=Abstraction({ fun_name=Some (0, x); fun_iface=p;
-				    fun_body=brs; fun_typ=Types.any; fun_fv=[] }) }
-	  | "match"; e1 = SELF; "with"; b = LIST1 branch ->
-	  let loc = `File(Loc.file_name _loc),
-	    Loc.start_off _loc - Loc.start_bol _loc,
-	    Loc.stop_off _loc - Loc.start_bol _loc in
-	  let brs = { br_typ=Types.any; br_accept=Types.any; br_branches=b } in
-	  { exp_loc=loc; exp_typ=Types.any; exp_descr=Match(e1, brs) } ]
+	  [ "fun"; x = LIDENT; p = LIST1 param; ":"; t = UIDENT; "->";
+	    e = SELF -> Abstr(_loc, x, p, t, e)
+          | "match"; e = SELF; "with"; b = LIST1 branch -> Match(_loc, e, b) ]
       | "pair" LEFTA
-	  [ e1 = SELF; ","; e2 = SELF ->
-	  let loc = `File(Loc.file_name _loc),
-	    Loc.start_off _loc - Loc.start_bol _loc,
-	    Loc.stop_off _loc - Loc.start_bol _loc in
-	  { exp_loc=loc; exp_typ=Types.any; exp_descr=Pair(e1, e2) }
-	  | e1 = SELF ; "."; e2 = SELF ->
-	  let loc = `File(Loc.file_name _loc),
-	    Loc.start_off _loc - Loc.start_bol _loc,
-	    Loc.stop_off _loc - Loc.start_bol _loc in
-	  { exp_loc=loc; exp_typ=Types.any; exp_descr=Apply(e1, e2) } ]
+	  [ e1 = SELF; ","; e2 = SELF -> Pair(_loc, e1, e2)
+	  | e1 = SELF ; "."; e2 = SELF -> Apply(_loc, e1, e2) ]
       | "paren" [ "("; e = SELF; ")" -> e ]
-      | "var"
-	  [ x = LIDENT ->
-	    let loc = `File(Loc.file_name _loc),
-	      Loc.start_off _loc - Loc.start_bol _loc,
-	      Loc.stop_off _loc - Loc.start_bol _loc in
-	    { exp_loc=loc; exp_typ=Types.any; exp_descr=Var(0, x) } ]
-      | "int"
-	  [ x = INT ->
-	    let loc = `File(Loc.file_name _loc),
-	      Loc.start_off _loc - Loc.start_bol _loc,
-	      Loc.stop_off _loc - Loc.start_bol _loc in
-	    let x = Big_int.big_int_of_int (int_of_string x) in
-	    { exp_loc=loc; exp_typ=Types.any; exp_descr=Cst(Types.Integer x) } ]
-      | "string"
-	  [ x = STRING ->
-	    let loc = `File(Loc.file_name _loc),
-	      Loc.start_off _loc - Loc.start_bol _loc,
-	      Loc.stop_off _loc - Loc.start_bol _loc in
-            let x = Types.String (0, (String.length x) - 1, x,
-				  Types.Integer (Big_int.big_int_of_int 0)) in
-	    { exp_loc=loc; exp_typ=Types.any; exp_descr=Cst x } ]
+      | "var" [ x = LIDENT -> Var(_loc, x) ]
+      | "int" [ x = INT -> Int(_loc, int_of_string x) ]
+      | "string" [ x = STRING -> String(_loc, x) ]
       ];
 
-    param:[[p = LIDENT; ":"; t = UIDENT -> Types.any, Types.any]];
+    param:[[p = LIDENT; ":"; t = UIDENT -> _loc, p, t]];
 
-    branch:
-      [
-	"branch" LEFTA
-	  [ "|"; t = match_value; "->"; e = expression ->
-	  let loc = `File(Loc.file_name _loc),
-	    Loc.start_off _loc - Loc.start_bol _loc,
-	    Loc.stop_off _loc - Loc.start_bol _loc in
-	  let node = Patterns.make [] in
-	  { br_loc=loc; br_used=true; br_ghost=false; br_vars_empty=[];
-	    br_pat=node; br_body=e } ]
-      ];
+    branch:[ "branch" [ "|"; t = match_value; "->"; e = expression ->
+    _loc, t, e ]];
 
     match_value:
       [
-	"pair" LEFTA [ e1 = SELF; ","; e2 = SELF ->
-	let loc = `File(Loc.file_name _loc),
-	  Loc.start_off _loc - Loc.start_bol _loc,
-	  Loc.stop_off _loc - Loc.start_bol _loc in
-	{ exp_loc=loc; exp_typ=Types.any; exp_descr=Pair(e1, e2) } ]
+	"pair" LEFTA [ e1 = SELF; ","; e2 = SELF -> MPair(_loc, e1, e2) ]
       | "paren" [ "("; e = SELF; ")" -> e ]
-      | "var" [ x = LIDENT; ":"; t = UIDENT ->
-      let loc = `File(Loc.file_name _loc),
-	Loc.start_off _loc - Loc.start_bol _loc,
-	Loc.stop_off _loc - Loc.start_bol _loc in
-      { exp_loc=loc; exp_typ=Types.any; exp_descr=Var(0, x) } ]
-      | "int" [ x = INT ->
-	let loc = `File(Loc.file_name _loc),
-	  Loc.start_off _loc - Loc.start_bol _loc,
-	  Loc.stop_off _loc - Loc.start_bol _loc in
-	let x = Big_int.big_int_of_int (int_of_string x) in
-	{ exp_loc=loc; exp_typ=Types.any; exp_descr=Cst(Types.Integer x) } ]
-      | "string" [ x = STRING ->
-	let loc = `File(Loc.file_name _loc),
-	  Loc.start_off _loc - Loc.start_bol _loc,
-	  Loc.stop_off _loc - Loc.start_bol _loc in
-	let x = Types.String (0, (String.length x) - 1, x,
-			      Types.Integer (Big_int.big_int_of_int 0)) in
-	{ exp_loc=loc; exp_typ=Types.any; exp_descr=Cst x } ]
+      | "var" [ x = LIDENT; ":"; t = UIDENT -> MVar(_loc, x, t) ]
+      | "int" [ x = INT -> MInt(_loc, int_of_string x) ]
+      | "string" [ x = STRING -> MString(_loc, x) ]
       ];
     END;;
 
   let of_string s file = Gram.parse_string exp_eoi (Loc.mk file) s
 end
+
+let get_loc expr = match expr with
+  | Apply (loc, _, _) -> loc
+  | Abstr (loc, _, _, _, _) -> loc
+  | Match (loc, _, _) -> loc
+  | Pair (loc, _, _) -> loc
+  | Var (loc, _) -> loc
+  | Int (loc, _) -> loc
+  | String (loc, _) -> loc

tests/lambda/src/parse.mli

 open Camlp4.PreCast
 
+type expr =
+  | Apply of Loc.t * expr * expr
+  | Abstr of Loc.t * fun_name * params * ptype * expr
+  | Match of Loc.t * expr * branches
+  | Pair of Loc.t * expr * expr
+  | Var of Loc.t * string
+  | Int of Loc.t * int
+  | String of Loc.t * string
+and fun_name = string
+and params = (Loc.t * string * ptype) list
+and branches = (Loc.t * match_value * expr) list
+and match_value =
+  | MPair of Loc.t * match_value * match_value
+  | MVar of Loc.t * string * ptype
+  | MInt of Loc.t * int
+  | MString of Loc.t * string
+and ptype = string
+
 module ExprParser : sig
-  val of_string : string -> string -> Typed.texpr
+  val of_string : string -> string -> expr
 end
+
+val get_loc : expr -> Loc.t