summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGuillaume Seguin <guillaume@segu.in>2009-01-15 22:40:29 +0100
committerGuillaume Seguin <guillaume@segu.in>2009-01-15 22:40:29 +0100
commit656cff28c55590648b17ba36553e748cda445e2b (patch)
treed52477bf40a12bec4625773d306135aef2121474
parentd044a93f39682268ffca60159bd1a0706d2d6050 (diff)
downloadpetitcaml-656cff28c55590648b17ba36553e748cda445e2b.tar.gz
petitcaml-656cff28c55590648b17ba36553e748cda445e2b.tar.bz2
[petitcaml] Fix another bunch of error localisation bugs
-rw-r--r--parser.mly13
-rw-r--r--tests/typing/match-fail.ml2
-rw-r--r--tests/typing/match-fail3.ml2
-rw-r--r--typing.ml40
4 files changed, 33 insertions, 24 deletions
diff --git a/parser.mly b/parser.mly
index 7f13b40..9f1936d 100644
--- a/parser.mly
+++ b/parser.mly
@@ -79,7 +79,10 @@ simple_expr:
| LPAREN e = expr COMMA exprs = separated_nonempty_list(COMMA, expr) RPAREN
{ locd_expr (Etuple (e::exprs)) (make_loc $startpos $endpos) }
| LBRACE exprs = separated_list(SEMICOLON, expr) RBRACE
- { List.fold_right (fun expr base -> raw_expr (Elistcons (expr, base)))
+ { List.fold_right (fun expr base ->
+ { e = (Elistcons (expr, base)) ;
+ t = None ;
+ loc = (make_start_end_loc expr.loc base.loc) })
exprs
(locd_expr (Econst (Cemptylist))
(make_loc $startpos $endpos)) }
@@ -95,9 +98,9 @@ expr:
{ e = (Ecall (base, arg)) ;
t = None ;
loc = arg.loc })
- ({ e = (Ecall (func, arg)) ;
+ { e = (Ecall (func, arg)) ;
t = None ;
- loc = (make_start_end_loc func.loc arg.loc) })
+ loc = (make_start_end_loc func.loc arg.loc) }
args }
| FUNCTION m = motif RIGHTARROW e = expr
{ locd_expr (Efunc ({ name = None ;
@@ -122,7 +125,9 @@ expr:
EQ fbody = expr IN body = expr
{ locd_expr (Eletin (locd_motif (Mident id) (make_loc $startpos(id)
$endpos(id)),
- raw_expr (make_func id recur fbody args),
+ { e = (make_func id recur fbody args) ;
+ t = None ;
+ loc = fbody.loc },
body))
(make_loc $startpos $endpos) }
| MATCH e = expr WITH
diff --git a/tests/typing/match-fail.ml b/tests/typing/match-fail.ml
index f3a6e6a..396435f 100644
--- a/tests/typing/match-fail.ml
+++ b/tests/typing/match-fail.ml
@@ -1,7 +1,7 @@
(*
return : 1
output :
-File "tests/typing/match-fail.ml", line 8, characters 4-39:
+File "tests/typing/match-fail.ml", line 9, characters 21-27:
Erreur dans l'analyse sémantique : Motif interdit dans le filtrage de la queue de liste
*)
let rec h l =
diff --git a/tests/typing/match-fail3.ml b/tests/typing/match-fail3.ml
index f2a7070..42cda8d 100644
--- a/tests/typing/match-fail3.ml
+++ b/tests/typing/match-fail3.ml
@@ -1,7 +1,7 @@
(*
return : 1
output :
-File "tests/typing/match-fail3.ml", line 8, characters 4-27:
+File "tests/typing/match-fail3.ml", line 9, characters 21-22:
Erreur dans l'analyse sémantique : Variable a non unique dans ce motif
*)
let rec h l =
diff --git a/typing.ml b/typing.ml
index 5ce6b91..0c3c0ba 100644
--- a/typing.ml
+++ b/typing.ml
@@ -234,15 +234,15 @@ let find ident env =
module Sset = Set.Make(String)
(* Détermine l'ensemble des variables apparaîssant dans le motif *)
-let rec motif_vars loc vars m =
+let rec motif_vars vars m =
match m.m with
| Munderscore -> vars
| Mident ident when Sset.mem ident vars ->
- typing_error loc
+ typing_error m.motif_loc
(Printf.sprintf "Variable %s non unique \
dans ce motif" ident)
| Mident ident -> Sset.add ident vars
- | Mtuple l -> List.fold_left (motif_vars loc) vars l
+ | Mtuple l -> List.fold_left motif_vars vars l
(* Ajoute les identifiants du motif m typé comme t à l'environnement env
avec la fonction d'ajout add_func *)
@@ -453,25 +453,29 @@ let rec w env e =
and tail_t = w_motif tail_m
in
unify match_expr.loc match_t (Tlist head_t);
- let vars_base =
+ begin
match tail_m.m with
| Mtuple _ ->
- typing_error e.loc "Motif interdit dans le \
- filtrage de la queue de \
- liste"
- | Mident ident -> Sset.singleton ident
- | Munderscore -> Sset.empty
+ typing_error tail_m.motif_loc
+ "Motif interdit dans le \
+ filtrage de la queue de \
+ liste"
+ | Mident ident -> ()
+ | Munderscore -> ()
+ end;
+ unify match_expr.loc tail_t (Tlist head_t);
+ let env2 = add_motif (add_motif env head_m head_t)
+ tail_m
+ tail_t
+ and _ = motif_vars Sset.empty
+ ({ m = (Mtuple [head_m ; tail_m]) ;
+ motif_loc = None ;
+ motif_t = None })
in
- unify match_expr.loc tail_t (Tlist head_t);
- let env2 = add_motif (add_motif env head_m head_t)
- tail_m
- tail_t
- and _ = motif_vars e.loc vars_base head_m
+ let result_t = w env2 expr
in
- let result_t = w env2 expr
- in
- unify expr.loc result_t empty_t;
- result_t
+ unify expr.loc result_t empty_t;
+ result_t
| Eclos _ -> failwith "w : Unreachable matching"
in
let t = w_aux e