[r2002-10-14 22:05:40 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-14 22:05:40+00:00

depend

-parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi 
-parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx 
+parser/ast.cmo: types/patterns.cmi types/types.cmi 
+parser/ast.cmx: types/patterns.cmx types/types.cmx 
 parser/location.cmo: parser/location.cmi 
 parser/location.cmx: parser/location.cmi 
 parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \

parser/parser.ml

@@ -66,7 +66,7 @@ module P = struct
   ];
 
   arrow: [
-    [ t1 = pat LEVEL "prod"; "->"; t2 = pat -> (t1,t2)]
+    [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
   ];
 
   branches: [
@@ -130,8 +130,8 @@ module P = struct
                     mk loc (Record (Types.label l,o,x))
                 ] SEP ";" ->
         match r with
-          | [] -> mk noloc (Internal Types.Record.any)
-          | h::t -> List.fold_left (fun t1 t2 -> mk noloc (And (t1,t2))) h t
+          | [] -> mk loc (Internal Types.Record.any)
+          | h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
       ] ];
   
   const:

typing/typed.ml

@@ -14,7 +14,7 @@ open Location
 type tpat = Patterns.node
 type ttyp = Types.node
 
-type texpr  = { exp_loc : Location.loc; 
+type texpr  = { exp_loc : loc; 
 		mutable exp_typ : Types.descr; 
 		exp_descr : texpr';
 	      }
@@ -36,18 +36,21 @@ and  texpr' =
 
 and abstr = { 
   fun_name : string option; 
-  fun_iface : (ttyp * ttyp) list;
+  fun_iface : (Types.descr * Types.descr) list;
   fun_body : branches;
   fun_typ  : Types.descr;
   fun_fv   : string list;
 }
 
-and branches = branch list
-and branch = 
-    { mutable br_used : bool; 
-      mutable br_typ : Types.descr;   (* TODO: move to branches and update *)
-      br_pat : tpat; 
-      br_body :  texpr }
+and branches = { 
+  mutable br_typ : Types.descr;
+  br_branches: branch list
+}
+and branch = { 
+  mutable br_used : bool; 
+  br_pat : tpat; 
+  br_body :  texpr 
+}
     
 and op = string
 

typing/typer.ml

@@ -3,14 +3,17 @@
 
 open Location
 open Ast
-exception ParsingPattern of string
 
-let raise_loc loc msg = raise (Location loc (ParsingPattern msg))
+exception Pattern of string
+exception NonExhaustive of Types.descr
+exception Constraint of Types.descr * Types.descr * string
+
+let raise_loc loc exn = raise (Location (loc,exn))
 
 (* Internal representation as a graph (desugar recursive types and regexp),
    to compute freevars, etc... *)
 
-type ti = { 
+type ti = {
   id : int; 
   mutable loc' : loc;
   mutable fv : string SortedList.t option; 
@@ -19,7 +22,7 @@ type ti = {
   mutable pat_node: Patterns.node option
 } 
 and descr =
-   [ `Alias of ti
+   [ `Alias of string * ti
    | `Type of Types.descr
    | `Or of ti * ti
    | `And of ti * ti
@@ -41,8 +44,14 @@ let mk' =
   let counter = ref 0 in
   fun () ->
     incr counter;
-    let rec x = { id = !counter; loc' = noloc; fv = None; descr' = `Alias x; 
-		  type_node = None; pat_node = None } in
+    let rec x = { 
+      id = !counter; 
+      loc' = noloc; 
+      fv = None; 
+      descr' = `Alias ("__dummy__", x);  
+      type_node = None; 
+      pat_node = None 
+    } in
     x
 
 let cons loc d =
@@ -146,13 +155,16 @@ let rec compile env { loc = loc; descr = d } : ti =
   match (d : Ast.ppat') with
   | PatVar s -> 
       (try StringMap.find s env
-       with Not_found -> raise_loc loc "Undefined variable"
+       with Not_found -> 
+	 raise_loc loc (Pattern ("Undefined type variable " ^ s))
       )
   | Recurs (t, b) ->
       let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
       let env = 
 	List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
-      List.iter (fun (v,t,x) -> x.descr' <- `Alias (compile env t)) b;
+      List.iter 
+	(fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t)) 
+	b;
       compile env t
   | Regexp (r,q) -> compile env (Regexp.compile r q)
   | Internal t -> cons loc (`Type t)
@@ -171,7 +183,7 @@ let rec comp_fv seen s =
     | None ->
 	let l = 
 	  match s.descr' with
-	    | `Alias x -> if List.memq s seen then [] else comp_fv (s :: seen) x
+	    | `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
 	    | `Or (s1,s2) 
 	    | `And (s1,s2)
 	    | `Diff (s1,s2)
@@ -190,8 +202,11 @@ let fv = comp_fv []
 
 let rec typ seen s : Types.descr =
   match s.descr' with
-    | `Alias x ->
-	if List.memq s seen then failwith "Unguarded recursion in this type"
+    | `Alias (v,x) ->
+	if List.memq s seen then 
+	  raise_loc s.loc' 
+	    (Pattern 
+	       ("Unguarded recursion on variable " ^ v ^ " in this type"))
 	else typ (s :: seen) x
     | `Type t -> t
     | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
@@ -200,7 +215,7 @@ let rec typ seen s : Types.descr =
     | `Times (s1,s2) ->	Types.times (typ_node s1) (typ_node s2)
     | `Arrow (s1,s2) ->	Types.arrow (typ_node s1) (typ_node s2)
     | `Record (l,o,s) -> Types.record l o (typ_node s)
-    | _ -> failwith "This is not a type"
+    | `Capture _ | `Constant _ -> assert false
 
 and typ_node s : Types.node =
   match s.type_node with
@@ -217,19 +232,29 @@ let type_node s = Types.internalize (typ_node s)
 let rec pat seen s : Patterns.descr =
   if fv s = [] then Patterns.constr (type_node s) else
   match s.descr' with
-    | `Alias x ->
-	if List.memq s seen then failwith "Unguarded recursion in this pattern"
+    | `Alias (v,x) ->
+	if List.memq s seen then 
+	  raise_loc s.loc' 
+	    (Pattern 
+	       ("Unguarded recursion on variable " ^ v ^ " in this pattern"))
 	else pat (s :: seen) x
     | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
     | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
     | `Diff (s1,s2) when fv s2 = [] ->
 	let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
 	Patterns.cap (pat seen s1) (Patterns.constr s2)
+    | `Diff _ ->
+	raise_loc s.loc' (Pattern "Difference not allowed in patterns")
     | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
     | `Record (l,false,s) -> Patterns.record l (pat_node s)
+    | `Record _ ->
+	raise_loc s.loc' 
+	  (Pattern "Optional field not allowed in record patterns")
     | `Capture x ->  Patterns.capture x
     | `Constant (x,c) -> Patterns.constant x c
-    | _ -> failwith "This is not a pattern"
+    | `Arrow _ ->
+	raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
+    | `Type _ -> assert false
 
 and pat_node s : Patterns.node =
   match s.pat_node with
@@ -243,7 +268,9 @@ and pat_node s : Patterns.node =
 
 let typ e =
   let e = compile StringMap.empty e in
-  if fv e = [] then type_node e else failwith "This is not a type"
+  if fv e = [] then type_node e 
+  else (raise_loc e.loc' 
+	  (Pattern "Capture variables are not allowed in types"))
 
 let pat e =
   let e = compile StringMap.empty e in
@@ -267,6 +294,9 @@ let rec expr { loc = loc; descr = d } =
 	  let t = List.fold_left 
 		    (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2)) 
 		    Types.any iface in
+	  let iface = List.map 
+			(fun (t1,t2) -> (Types.descr t1, Types.descr t2)) 
+			iface in
 	  let (fv0,body) = branches a.fun_body in
 	  let fv = match a.fun_name with
 	    | None -> fv0
@@ -318,11 +348,10 @@ let rec expr { loc = loc; descr = d } =
 		 let (fv2,e) = expr e in
 		 fv := Fv.union !fv fv2;
 		 { Typed.br_used = false;
-		   Typed.br_typ = Types.empty;
 		   Typed.br_pat = pat p;
 		   Typed.br_body = e }
 	      ) b in
-    (!fv,b)
+    (!fv, { Typed.br_typ = Types.empty; Typed.br_branches = b } )
 
 module Env = StringMap
 
@@ -343,9 +372,9 @@ and compute_type' loc env = function
 	| None -> env
 	| Some f -> Env.add f a.fun_typ env in
       List.iter (fun (t1,t2) ->
-		   let t = type_branches env (Types.descr t1) a.fun_body in
-		   if not (Types.subtype t (Types.descr t2)) then
-		     failwith "Constraint not satisfied"
+		   let t = type_branches loc env t1 a.fun_body in
+		   if not (Types.subtype t t2) then
+		     raise_loc loc (Constraint (t,t2,"Constraint not satisfied in interface"))
 		) a.fun_iface;
       a.fun_typ
   | Cst c -> Types.constant c
@@ -363,22 +392,25 @@ and compute_type' loc env = function
   | Op (op,e) -> assert false
   | Match (e,b) ->
       let t = compute_type env e in
-      type_branches env t b
+      type_branches loc env t b
   | Map (e,b) -> assert false
 
-and type_branches env targ branches =
+and type_branches loc env targ brs =
   if Types.is_empty targ then Types.empty 
-  else branches_aux env targ Types.empty branches
+  else (
+    brs.br_typ <- Types.cup brs.br_typ targ;
+    branches_aux loc env targ Types.empty brs.br_branches
+  )
     
-and branches_aux env targ tres = function
-  | [] -> failwith "Non-exhaustive pattern matching"
+and branches_aux loc env targ tres = function
+  | [] -> raise_loc loc (NonExhaustive targ)
   | b :: rem ->
       let p = b.br_pat in
       let acc = Types.descr (Patterns.accept p) in
 
       let targ' = Types.cap targ acc in
       if Types.is_empty targ' 
-      then branches_aux env targ tres rem
+      then branches_aux loc env targ tres rem
       else 
 	( b.br_used <- true;
 	  let res = Patterns.filter targ' p in
@@ -386,7 +418,10 @@ and branches_aux env targ tres = function
 		       (fun env (x,t) -> Env.add x (Types.descr t) env) 
 		       env res in
 	  let t = compute_type env' b.br_body in
-	  branches_aux env (Types.diff targ acc) (Types.cup t tres) rem 
+	  let tres = Types.cup t tres in
+	  let targ'' = Types.diff targ acc in
+	  if (Types.non_empty targ'') then 
+	    branches_aux loc env targ'' (Types.cup t tres) rem 
+	  else
+	    tres
 	)
-	  
-  

typing/typer.mli

-exception ParsingPattern of string
+exception Pattern of string
+exception NonExhaustive of Types.descr
+exception Constraint of Types.descr * Types.descr * string
 
 val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat