[r2005-01-18 15:43:21 by afrisch] 'always return the empty sequence' warning

Original author: afrisch
Date: 2005-01-18 15:43:21+00:00

driver/cduce.ml

@@ -185,7 +185,7 @@ let debug ppf tenv cenv = function
 	Types.Print.print (Types.descr t)
 	Patterns.Print.print (Patterns.descr p);
       let f = Patterns.filter (Types.descr t) p in
-      List.iter (fun (x,t) ->
+      IdMap.iteri (fun x t ->
 		   Format.fprintf ppf " %a:%a@." U.print (Id.value x)
 		     print_norm (Types.descr t)) f
   | `Accept p ->

parser/location.ml

@@ -51,6 +51,8 @@ let get_line_number src i =
   let lb = Ulexing.from_var_enc_channel enc ic in
   let rec count line start = lexer
     | '\n' | "\n\r" | '\r' ->
+	if (Ulexing.lexeme_start lb >= i) then (line, i - start)
+	else
 	aux (line + 1) (Ulexing.lexeme_end lb)
     | "#utf8" ->
 	enc := Ulexing.Utf8;

types/patterns.ml

@@ -439,8 +439,7 @@ and filter_node t p : Types.Positive.v id_map =
 let filter t p =
   let r = filter_node t p in
   memo_filter :=  MemoFilter.empty;
-  IdMap.get (IdMap.map Types.Positive.solve r)
-
+  IdMap.map Types.Positive.solve r
 let filter_descr t p =
   let r = filter_descr t p in
   memo_filter :=  MemoFilter.empty;

types/patterns.mli

@@ -34,7 +34,7 @@ end
 (* Pattern matching: static semantics *)
 
 val accept : node -> Types.Node.t
-val filter : Types.t -> node -> (id * Types.Node.t) list
+val filter : Types.t -> node -> Types.Node.t id_map
 
 
 (* Pattern matching: compilation *)

typing/typed.ml

@@ -81,6 +81,7 @@ and branches = {
 and branch = { 
   br_loc : loc;
   mutable br_used : bool; 
+  mutable br_vars_empty : fv;
   br_pat : tpat; 
   br_body :  texpr 
 }

typing/typer.ml

@@ -1109,6 +1109,7 @@ and branches env b =
       { 
 	Typed.br_loc = br_loc;
 	Typed.br_used = br_loc = noloc;
+	Typed.br_vars_empty = Patterns.fv p';
 	Typed.br_pat = p';
 	Typed.br_body = e } in
     cur_branch := Branch (br, !cur_branch) :: cur_br;
@@ -1390,8 +1391,14 @@ and branches_aux loc env targ tres constr precise = function
       else 
 	( b.br_used <- true;
 	  let res = Patterns.filter targ' p in
-	  let res = List.map (fun (x,t) -> (x,Types.descr t)) res in
-	  let env' = enter_values res env in
+	  let res = IdMap.map Types.descr res in
+	  
+	  b.br_vars_empty <-
+	    IdMap.domain (
+	      IdMap.filter (fun x t -> Types.subtype t Sequence.nil_type)
+		(IdMap.restrict res b.br_vars_empty));
+
+	  let env' = enter_values (IdMap.get res) env in
 	  let t = type_check env' b.br_body constr precise in
 	  let tres = if precise then Types.cup t tres else tres in
 	  let targ'' = Types.diff targ acc in
@@ -1426,7 +1433,7 @@ and type_let_decl env l =
   let acc = Types.descr (Patterns.accept l.let_pat) in
   let t = type_check env l.let_body acc true in
   let res = Patterns.filter t l.let_pat in
-  List.map (fun (x,t) -> (x, Types.descr t)) res
+  IdMap.mapi_to_list (fun x t -> (x, Types.descr t)) res
 
 and type_rec_funs env l =
   let typs = 
@@ -1449,7 +1456,27 @@ let rec unused_branches b =
     (fun (Branch (br,s)) -> 
        if not br.br_used 
        then warning br.br_loc "This branch is not used"
-       else unused_branches s
+       else (
+	 if not (IdSet.is_empty br.br_vars_empty)
+	 then (
+	   let msg = 
+	     try
+	       let l = 
+		 List.map 
+		   (fun x ->
+		      let x = Ident.to_string x in
+		      if x = "$$$" then raise Exit else x)
+		   (IdSet.get br.br_vars_empty) in
+	       let l = String.concat "," l in
+	       "The following variables always match the empty sequence: " ^
+		 l 
+	     with Exit ->
+	       "This projection always returns the empty sequence"
+	   in
+	   warning br.br_loc msg
+	 );
+	 unused_branches s
+       )
     )
     b