[TESTS][LAMBDA] Management of types improved

tests/lambda/GRAMMAR

@@ -31,5 +31,6 @@ type_id = [A-Z][A-Za-z0-9_]*
 complex_type_id = [A-Z][A-Za-z0-9_]*
 | complex_type_id * complex_type_id
 | complex_type_id -> complex_type_id
+| "(" complex_type_id ")"
 
 integer = [0-9]+

tests/lambda/src/compute.ml

@@ -13,12 +13,21 @@ exception Error
 
 (* TODO: We will need a much better representation of types and a much better
 function when we'll add union types and polymorphism. *)
-let is_subtype t1 t2 = if String.compare t1 t2 = 0 then true else false
+let rec is_subtype arg1 arg2 = match arg1, arg2 with
+  | Type(t), Type(u) -> if String.compare t u = 0 then true else false
+  | TPair(t1, t2), TPair(u1, u2) -> (is_subtype t1 u1) && (is_subtype t2 u2)
+  | TArrow(t1, t2), TArrow(u1, u2) -> (is_subtype t1 u1) && (is_subtype t2 u2)
+  | _ -> false
 
 let type_of_string s = match s with
   | "Int" -> interval [Intervals.Any]
   | _ -> Types.empty
 
+let rec type_of_ptype arg = match arg with
+  | Type(t) -> type_of_string t
+  | TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
+  | TArrow(t1, t2) -> arrow (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
+
 let rec type_of_iface iface res = match iface with
   | (ptype, rtype) :: rest -> type_of_iface rest
     (cup (arrow (cons ptype) (cons rtype)) res)
@@ -36,7 +45,7 @@ let rec _to_typed env l expr =
       parse_abstr env l loc (Some(0, fun_name)) params rtype body
     | Match (_, e, t, b) ->
       let b = parse_branches env l t b [] in
-      let t = type_of_string t in
+      let t = type_of_ptype t in
       let brs = { br_typ=t; br_accept=t; br_branches=b } in
       let _, _, exp_descr = _to_typed env l e in
       env, l, { exp_loc=loc; exp_typ=t;
@@ -84,7 +93,7 @@ and parse_abstr env l loc fun_name params rtype body =
     (* TODO: Fix exp_typ *)
     env, l, { exp_loc=loc; exp_typ=any; exp_descr=Abstraction(abstr) }
   in
-  _parse_abstr env l loc fun_name params (type_of_string rtype) body 0
+  _parse_abstr env l loc fun_name params (type_of_ptype rtype) body 0
 
 and make_node fv =
   let d = (match fv with
@@ -95,15 +104,15 @@ and make_node fv =
 
 and parse_iface env l params fv nb iface rtype = match params with
   | (_, pname, ptype) :: [] -> true, env, (Locals.add pname nb l),
-    (fv @ [nb, pname]), (iface @ [type_of_string ptype, rtype]), []
+    (fv @ [nb, pname]), (iface @ [type_of_ptype ptype, rtype]), []
   | (_, pname, ptype) :: rest -> false, env, (Locals.add pname nb l),
-    (fv @ [nb, pname]), (iface @ [itype rest (type_of_string ptype), rtype]),
+    (fv @ [nb, pname]), (iface @ [itype rest (type_of_ptype ptype), rtype]),
     rest
   | [] -> true, env, l, fv, iface, []
 
 and itype iface res = match iface with
   | (_, _, t) :: rest -> itype rest
-    (arrow (cons res) (cons (type_of_string t)))
+    (arrow (cons res) (cons (type_of_ptype t)))
   | [] -> res
 
 and parse_branches env l toptype brs res = match brs with
@@ -133,9 +142,19 @@ and make_patterns t fv d = incr Patterns.counter;
     Patterns.accept=(cons t); fv=fv }
 
 and parse_match_value env l list p toptype = match p with
-  | MPair (_, m1, m2) ->
-    let t1, d1, list, l, b1 = parse_match_value env l list m1 toptype in
-    let t2, d2, list, l, b2 = parse_match_value env l list m2 toptype in
+  | MPair (loc, m1, m2) ->
+    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
+    let fname = Loc.file_name loc in
+    let top1, top2 =
+      (match toptype with | TPair(t1, t2) -> t1, t2 | _ ->
+	Printf.eprintf "File %s, line %d, characters %d-%d:\nError:" fname
+	  line cbegin cend;
+	Printf.eprintf " type %s is not a pair\n"
+	  (Types.Print.to_string (type_of_ptype toptype)); raise Error) in
+    let t1, d1, list, l, b1 = parse_match_value env l list m1 top1 in
+    let t2, d2, list, l, b2 = parse_match_value env l list m2 top2 in
     times (cons t1) (cons t2),
     Patterns.Times (make_patterns t1 [] d1, make_patterns t2 [] d2),
     list, l, b1 && b2;
@@ -144,16 +163,16 @@ and parse_match_value env l list p toptype = match p with
     let l = Locals.add mname lsize l in
     let list = list @ [lsize, mname] in
     let d1 = any, list, Patterns.Capture(lsize, mname) in
-    let t2 = type_of_string mtype in
+    let t2 = type_of_ptype mtype in
     let d2 = t2, [], Patterns.Constr(t2) in
     t2, Patterns.Cap(d1, d2), list, l, is_subtype toptype mtype
   | MInt (_, i) ->
     let t = constant (Integer(big_int_of_int i)) in
-    t, Patterns.Constr(t), list, l, is_subtype toptype "Int"
+    t, Patterns.Constr(t), list, l, is_subtype toptype (Type("Int"))
   | MString (_, s) ->
     let t = constant (String(0, String.length s - 1, s,
 			     Integer(big_int_of_int 0))) in
-    t, Patterns.Constr(t), list, l, is_subtype toptype "String"
+    t, Patterns.Constr(t), list, l, is_subtype toptype (Type("String"))
 
 let to_typed expr =
   let env, l, expr = _to_typed empty_toplevel Locals.empty expr in

tests/lambda/src/main.ml

@@ -149,7 +149,7 @@ in
 try
   let expr = ExprParser.of_string str file in
   let env, texpr = Compute.to_typed expr in
-  eprintf "%s\n" (typed_to_string texpr); print_env env.Compile.vars;
+(*  eprintf "%s\n" (typed_to_string texpr); print_env env.Compile.vars;*)
   let evalexpr = Compile.compile_eval_expr env texpr in
   print_value evalexpr; printf "\n"
 with

tests/lambda/src/parse.ml

@@ -17,7 +17,10 @@ and match_value =
   | MVar of Loc.t * string * ptype
   | MInt of Loc.t * int
   | MString of Loc.t * string
-and ptype = string
+and ptype =
+  | Type of string
+  | TPair of ptype * ptype
+  | TArrow of ptype * ptype
 
 module ExprParser = struct
 
@@ -58,12 +61,13 @@ module ExprParser = struct
       | "string" [ x = STRING -> MString(_loc, x) ]
       ];
 
-    type_id: [ "atom_type" [ t = UIDENT -> t ]
+    type_id: [ "atom_type" [ t = UIDENT -> Type(t) ]
 	     | [ "("; t = complex_type_id; ")" -> t ]];
 
-    complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> t ]
-		     | [ t1 = SELF; "*"; t2 = SELF -> t1 ^ "*" ^ t2
-		       | t1 = SELF; "->"; t2 = SELF -> t1 ^ "->" ^ t2 ]];
+    complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> Type(t)
+					    | "("; t = SELF; ")" -> t ]
+		     | [ t1 = SELF; "*"; t2 = SELF -> TPair(t1, t2)
+		       | t1 = SELF; "->"; t2 = SELF -> TArrow(t1, t2) ]];
 
     END;;
 

tests/lambda/src/parse.mli

@@ -16,7 +16,10 @@ and match_value =
   | MVar of Loc.t * string * ptype
   | MInt of Loc.t * int
   | MString of Loc.t * string
-and ptype = string
+and ptype =
+  | Type of string
+  | TPair of ptype * ptype
+  | TArrow of ptype * ptype
 
 module ExprParser : sig
   val of_string : string -> string -> expr

tests/lambda/tests/eval/refs/match_error_simple.ref

-File ./tests/eval/tests/match_error_simple.test, line 1, characters 49-50:
-Unbound identifier a
+File ./tests/eval/tests/match_error_simple.test, line 1, characters 6-7:
+Unbound identifier x

tests/lambda/tests/eval/tests/firsts.test

-fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) -> match x,y : (Int*Int) with
+fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) -> match x,y : ((Int*Int)*(Int*Int)) with
 | (a : Int,_ : Int),(b : Int,_ : Int) -> a,b