[TESTS][LAMBDA] Ignore unused branches; code cleanup

tests/lambda/GRAMMAR

@@ -5,8 +5,9 @@ expr = id
 | expr "." expr
 | expr "," expr
 | "(" expr ")"
-| "match" expr "with" "|" match_value "->" expr branches
+| "match" expr ":" type_id "with" "|" match_value "->" expr branches
 
+(* TODO: Add the "_" special keyword *)
 abstr = "fun" id id ":" type_id params ":" type_id "->" expr
 
 match_value = id ":" type_id
@@ -23,6 +24,7 @@ branches = (* empty *)
 
 id = [a-z_][A-Za-z0-9_]*
 
+(* TODO: Add union and polymorphic types *)
 type_id = [A-Z][A-Za-z0-9_]*
 
 integer = [0-9]+

tests/lambda/src/compute.ml

@@ -3,70 +3,56 @@ open Typed
 open Compile
 open Camlp4.PreCast
 
+(* Gives a unique id for a name *)
 module Locals = Map.Make(String)
 
+(* To throw in case of an unbound name *)
 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 _to_typed env l expr =
+  (* From Camlp4 locations to CDuce locations *)
+  let loc = caml_loc_to_cduce (get_loc expr) 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
+    | Parse.Apply (_, e1, e2) ->
       let _, _, e1 = _to_typed env l e1 in
       let _, _, e2 = _to_typed env l e2 in
       env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
-    | Abstr (loc, fun_name, params, return_type, body) ->
+    | Abstr (_, fun_name, params, return_type, body) ->
       parse_abstr env l 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 env l b [] in
+    | 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
       let _, _, exp_descr = _to_typed env l e in
       env, l, { exp_loc=loc; exp_typ=Types.empty;
 		exp_descr=Match(exp_descr, 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
+    | Pair (_, e1, e2) ->
       let _, _, exp_descr1 = _to_typed env l e1 in
       let _, _, exp_descr2 = _to_typed env l e2 in
       env, l, { exp_loc=loc; exp_typ=Types.empty;
 		exp_descr=Pair(exp_descr1, exp_descr2) }
-    | Var (loc, vname) ->
-      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
+    | Var (origloc, vname) ->
+      let line = Loc.start_line origloc in
+      let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
+      let cend = Loc.stop_off origloc - Loc.start_bol origloc in
       let index = (try Locals.find vname l with Not_found ->
 	Printf.eprintf "File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
-          (Loc.file_name loc) line cbegin cend vname; raise Error) in
-      let loc = `File(Loc.file_name loc), cbegin, cend in
+          (Loc.file_name origloc) line cbegin cend vname; raise Error) in
       env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Var(index, 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
+    | Int (_, i) ->
       let i = Big_int.big_int_of_int i in
       env, l, { exp_loc=loc; exp_typ=Types.empty;
 		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
+    | String (_, s) ->
       let s = Types.String (0, (String.length s) - 1, s,
 			    Types.Integer (Big_int.big_int_of_int 0)) in
       env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Cst s }
 
 and parse_abstr env l 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 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 brloc = caml_loc_to_cduce (get_loc body) in
   let env, l, fv, iface = parse_iface env l params [] 0 [] in
   let node = Patterns.make fv in
   let _, _, br_body = _to_typed env l body in
@@ -84,18 +70,31 @@ and parse_iface env l params fv nb iface = match params with
       (iface @ [Types.empty, Types.empty])
   | [] -> env, l, fv, iface
 
-and parse_branches env l brs res = match brs with
+and parse_branches env l toptype 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 brloc = caml_loc_to_cduce loc in
+    let 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
     let node = Patterns.make [] in
-    let _, _, br_body = _to_typed env l e in
-    let b = { br_loc=loc; br_used=true; br_ghost=false; br_vars_empty=[];
+    let _, _, br_body = _to_typed env br_locals e 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 rest (res @ [b])
+    let fname = Loc.file_name loc in
+    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;
+    parse_branches env l toptype rest (res @ [b])
   | [] -> res
 
+and parse_match_value env l p toptype = match p with
+  | MPair (_) -> l, false; (* TODO: Allow pairs in types *)
+  | MVar (_, mname, mtype) -> Locals.add mname (Locals.cardinal l) l,
+    is_subtype toptype mtype
+  | MInt (_) -> l, is_subtype toptype "Int"
+  | MString (_) -> l, is_subtype toptype "String"
+
 let to_typed expr =
   let env, _, expr = _to_typed empty_toplevel Locals.empty expr in
   env, expr

tests/lambda/src/parse.ml

@@ -4,7 +4,7 @@ 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
+  | Match of Loc.t * expr * ptype * branches
   | Pair of Loc.t * expr * expr
   | Var of Loc.t * string
   | Int of Loc.t * int
@@ -33,7 +33,8 @@ module ExprParser = struct
 	"abstr" RIGHTA
 	  [ "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) ]
+          | "match"; e = SELF; ":"; t = UIDENT; "with"; b = LIST1 branch ->
+	  Match(_loc, e, t, b) ]
       | "pair" LEFTA
 	  [ e1 = SELF; ","; e2 = SELF -> Pair(_loc, e1, e2)
 	  | e1 = SELF ; "."; e2 = SELF -> Apply(_loc, e1, e2) ]
@@ -64,8 +65,12 @@ end
 let get_loc expr = match expr with
   | Apply (loc, _, _) -> loc
   | Abstr (loc, _, _, _, _) -> loc
-  | Match (loc, _, _) -> loc
+  | Match (loc, _, _, _) -> loc
   | Pair (loc, _, _) -> loc
   | Var (loc, _) -> loc
   | Int (loc, _) -> loc
   | String (loc, _) -> loc
+
+let caml_loc_to_cduce loc =
+  `File(Loc.file_name loc), Loc.start_off loc - Loc.start_bol loc,
+  Loc.stop_off loc - Loc.start_bol loc

tests/lambda/src/parse.mli

@@ -3,7 +3,7 @@ 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
+  | Match of Loc.t * expr * ptype * branches
   | Pair of Loc.t * expr * expr
   | Var of Loc.t * string
   | Int of Loc.t * int
@@ -23,3 +23,4 @@ module ExprParser : sig
 end
 
 val get_loc : expr -> Loc.t
+val caml_loc_to_cduce : Loc.t -> Cduce_loc.loc

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

-File ./tests/eval/tests/match_error_simple.test, line 1, characters 37-38:
+File ./tests/eval/tests/match_error_simple.test, line 1, characters 50-51:
 Unbound identifier a

tests/lambda/tests/eval/refs/match_simple_var.ref

+4

tests/lambda/tests/eval/refs/match_simple_var.res

+0

tests/lambda/tests/eval/refs/match_unused_branches.ref

+1

tests/lambda/tests/eval/refs/match_unused_branches.res

+0

tests/lambda/tests/eval/tests/match_error_simple.test

-match x with | (a : Int, b : Int) -> a
+match x : Pairofints with | (a : Int, b : Int) -> a

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

-match 1 with | 2 -> 2 | a : Int -> 3
+match 1 : Int with | 1 -> 1 | 2 -> 2

tests/lambda/tests/eval/tests/match_simple_var.test

+(fun f x -> match x with | y : Int -> x+y).2

tests/lambda/tests/eval/tests/match_unused_branches.test

+match 1 : Int with | s : String -> s | b : Bool -> b | i : Int -> i