[TESTS][LAMBDA] Add printer for typed ast; add test on match (fail because it

	has more than one used branches)

tests/lambda/src/compute.ml

@@ -2,6 +2,8 @@ open Parse
 open Typed
 open Compile
 open Camlp4.PreCast
+open Types
+open Big_int
 
 (* Gives a unique id for a name *)
 module Locals = Map.Make(String)
@@ -22,7 +24,7 @@ let rec _to_typed env l expr =
       let _, _, e2 = _to_typed env l e2 in
       env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
     | Abstr (_, fun_name, params, return_type, body) ->
-      parse_abstr env l loc fun_name params return_type body
+      parse_abstr env l loc (Some(0, fun_name)) params return_type body
     | Match (_, e, t, b) ->
       let b = parse_branches env l t b [] in
       let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=b } in
@@ -55,22 +57,30 @@ and parse_abstr env l loc fun_name params return_type body =
   let rec _parse_abstr env l fv loc fun_name params return_type body nb =
     let brloc = caml_loc_to_cduce (get_loc body) in
     let empty, env, l, nfv, iface, rest = parse_iface env l params [] nb [] in
-    let node = Patterns.make (fv @ nfv) in
+    let node = make_node (fv @ nfv) nfv in
     let body = if empty
       then let _, _, body = _to_typed env l body in body
-      else let _, _, body = _parse_abstr env l (fv @ nfv) loc fun_name rest
+      else let _, _, body = _parse_abstr env l (fv @ nfv) loc None rest
 	     return_type body (nb + 1) in body
     in
-    let br = { br_loc=brloc; br_used=true; br_ghost=false;
-               br_vars_empty=[]; br_pat=node; br_body=body } in
-    let brs = { br_typ=Types.empty; br_accept=Types.empty;
-		br_branches=[br] } in
-    let abstr = { fun_name=Some (0, fun_name); fun_iface=iface; fun_body=brs;
+    let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
+	      br_pat=node; br_body=body } in
+    let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=[b] } in
+    let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
 		  fun_typ=Types.empty; fun_fv=[] } in
     env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Abstraction(abstr) }
   in
   _parse_abstr env l [] loc fun_name params return_type body 0
 
+and make_node fv nfv =
+  let d = (match nfv with
+    | el :: rest -> Patterns.Capture(el)
+    | [] -> Patterns.Dummy)
+  in
+  incr Patterns.counter;
+  { Patterns.id=(!Patterns.counter); Patterns.descr=(Types.empty, fv, d);
+    Patterns.accept=(Types.make ()); Patterns.fv=fv }
+
 and parse_iface env l params fv nb iface = match params with
   | (_, pname, _) :: [] -> true, env, (Locals.add pname nb l),
     (fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), []
@@ -81,7 +91,7 @@ and parse_iface env l params fv nb iface = match params with
 and parse_branches env l toptype brs res = match brs with
   | (loc, p, e) :: rest ->
     let brloc = caml_loc_to_cduce loc in
-    let list, br_locals, br_used = parse_match_value env l [] p toptype in
+    let t, list, br_locals, br_used = parse_match_value env l [] p toptype in
     let line = Loc.start_line loc in
     let cbegin = Loc.start_off loc - Loc.start_bol loc in
     let cend = Loc.stop_off loc - Loc.start_bol loc in
@@ -91,20 +101,30 @@ and parse_branches env l toptype brs res = match brs with
       (if not br_used then
 	  (Printf.eprintf
 	     "File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
-	     fname line cbegin cend; Patterns.make [])
-       else Patterns.make list) in
+	     fname line cbegin cend; make_patterns [] t)
+       else make_patterns list t) in
     let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
 	      br_pat=node; br_body=br_body} in
     parse_branches env l toptype rest (res @ [b])
   | [] -> res
 
+and make_patterns fv pattype = incr Patterns.counter;
+  { Patterns.id=(!Patterns.counter);
+    Patterns.descr=(Types.empty,Ident.IdSet.empty,pattype);
+    Patterns.accept=(Types.make()); fv=fv }
+
 and parse_match_value env l list p toptype = match p with
-  | MPair (_) -> list, l, false; (* TODO: Allow pairs in types *)
+  | MPair (_) -> Patterns.Dummy, list, l, false;
+  (* TODO: Allow pairs in types *)
   | MVar (_, mname, mtype) ->
     let lsize = Locals.cardinal l in
-    (list @ [lsize, mname]), Locals.add mname lsize l, is_subtype toptype mtype
-  | MInt (_) -> list, l, is_subtype toptype "Int"
-  | MString (_) -> list, l, is_subtype toptype "String"
+    Patterns.Dummy, (list @ [lsize, mname]), Locals.add mname lsize l,
+    is_subtype toptype mtype
+  | MInt (_, i) -> Patterns.Constr(constant (Integer(big_int_of_int i))), list,
+    l, is_subtype toptype "Int"
+  | MString (_, s) -> Patterns.Constr(constant (
+    String(0,String.length s - 1,s, Integer(big_int_of_int 0)))),
+    list, l, is_subtype toptype "String"
 
 let to_typed expr =
   let env, _, expr = _to_typed empty_toplevel Locals.empty expr in

tests/lambda/src/main.ml

 open Printf
 open Parse
 open Value
+open Typed
+open Types
 open Camlp4.PreCast
 
 let load_file f =
@@ -11,6 +13,81 @@ let load_file f =
   close_in ic;
   s
 
+let rec typed_to_string e = match e with
+  | Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e.Typed.exp_descr ^ ")"
+  | Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e.Typed.exp_descr ^ ")"
+  | Typed.Var(id, name) -> "Var(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | Typed.ExtVar(_, (id, name), _) -> "ExtVar("
+    ^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
+    ^ ")"
+  | Typed.Apply(e1, e2) -> "(" ^ typed_to_string e1.Typed.exp_descr ^ ").("
+    ^ (typed_to_string e2.Typed.exp_descr) ^ ")"
+  | Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
+  | Typed.Cst(cst) -> const cst
+  | Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1.Typed.exp_descr) ^ ", " ^
+    (typed_to_string e2.Typed.exp_descr) ^ ")"
+  | Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
+  | Typed.Match(e, b) -> "Match(" ^ (typed_to_string e.Typed.exp_descr) ^ ", "
+    ^ (branches b.Typed.br_branches) ^ ")"
+  | _ -> assert false
+
+and const cst = match cst with
+  | Types.Integer(i) -> "Integer(" ^ (Intervals.V.to_string i) ^ ")"
+  | Types.Atom(a) -> "Atom(" ^ (Atoms.V.to_string a) ^ ")"
+  | Types.Char(c) -> "Char(" ^ (string_of_int (Chars.V.to_int c)) ^ ")"
+  | Types.Pair(c1, c2) -> "(" ^ const c1 ^ ", " ^ const c2 ^ ")"
+  | Types.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
+  | _ -> assert false
+
+and abst abstr = (match abstr.Typed.fun_name with
+  | Some (id, name) -> "name:(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ "), body:["
+  | None -> "name:<none>, body:[") ^
+  (branches abstr.Typed.fun_body.Typed.br_branches) ^ "], fv:["
+  ^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
+
+and branches brs = match brs with
+  | br :: [] -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
+    ^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
+    ^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
+    ^ (node br.Typed.br_pat) ^ "}; body:"
+    ^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}"
+  | br :: rest -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
+    ^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
+    ^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
+    ^ (node br.Typed.br_pat) ^ "}; body:"
+    ^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}, "
+    ^ (branches rest)
+  | [] -> ""
+
+and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
+  ^ (descr node.Patterns.descr) ^ "]; fv:[" ^ (fv_to_string node.Patterns.fv)
+  ^ "]"
+
+and descr (t, fv, d) = "<type>; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
+
+and descr2 d = match d with
+  | Patterns.Constr(t) -> "<type>"
+  | Patterns.Cup(d1, d2) -> "Cup(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
+  | Patterns.Cap(d1, d2) -> "Cap(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
+  | Patterns.Times(n1, n2) -> "Times(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
+  | Patterns.Xml(n1, n2) -> "Xml(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
+  | Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", "
+    ^ (node n) ^ ")"
+  | Patterns.Capture((id, name)) -> "Capture(" ^ "<id>, "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | Patterns.Constant((id, name), ct) -> "Constant((" ^ "<id>, "
+    ^ (Encodings.Utf8.to_string name) ^ "), " ^ const ct ^ ")"
+  | Patterns.Dummy -> "Dummy"
+
+and fv_to_string fv = match fv with
+  | (id, name) :: [] -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | (id, name) :: rest -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ "), " ^ (fv_to_string rest)
+  | [] -> ""
+
 let rec print_value v = match v with
   | Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
     print_value v2; printf ")"
@@ -36,6 +113,7 @@ in
 try
   let expr = ExprParser.of_string str file in
   let env, texpr = Compute.to_typed expr in
+(*  printf "%s\n" (typed_to_string texpr.exp_descr);*)
   let evalexpr = Compile.compile_eval_expr env texpr in
   print_value evalexpr; printf "\n"
 with

tests/lambda/tests/eval/refs/match_medium.ref

+1

tests/lambda/tests/eval/refs/match_medium.res

+0

tests/lambda/tests/eval/tests/match_medium.test

+(fun f x : Int : Int -> match x : Int with | 1 -> 0 | x : Int -> x).1

tests/lambda/tests/eval/tests/match_simple.test

-match 1 : Int with | 1 -> 1 | 2 -> 2
+match 1 : Int with | 1 -> 1 | "true" -> "true"