[r2002-11-13 09:47:59 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-13 09:47:59+00:00

typing/typer.ml

@@ -344,15 +344,19 @@ let register_global_types glb b =
 
 module Fv = StringSet
 
-let rec expr glb { loc = loc; descr = d } = 
+(* IDEA: introduce a node Loc in the AST to override nolocs
+   in sub-expressions *)
+   
+let rec expr loc' glb { loc = loc; descr = d } = 
+  let loc =  if loc = noloc then loc' else loc in
   let (fv,td) = 
     match d with
       | Forget (e,t) ->
-	  let (fv,e) = expr glb e and t = typ glb t in
+	  let (fv,e) = expr loc glb e and t = typ glb t in
 	  (fv, Typed.Forget (e,t))
       | Var s -> (Fv.singleton s, Typed.Var s)
       | Apply (e1,e2) -> 
-	  let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in
+	  let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
 	  (Fv.union fv1 fv2, Typed.Apply (e1,e2))
       | Abstraction a ->
 	  let iface = List.map (fun (t1,t2) -> (typ glb t1, typ glb t2)) 
@@ -363,7 +367,7 @@ let rec expr glb { loc = loc; descr = d } =
 	  let iface = List.map 
 			(fun (t1,t2) -> (Types.descr t1, Types.descr t2)) 
 			iface in
-	  let (fv0,body) = branches glb a.fun_body in
+	  let (fv0,body) = branches loc glb a.fun_body in
 	  let fv = match a.fun_name with
 	    | None -> fv0
 	    | Some f -> Fv.remove f fv0 in
@@ -378,20 +382,21 @@ let rec expr glb { loc = loc; descr = d } =
 	  )
       | Cst c -> (Fv.empty, Typed.Cst c)
       | Pair (e1,e2) ->
-	  let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in
+	  let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
 	  (Fv.union fv1 fv2, Typed.Pair (e1,e2))
       | Xml (e1,e2) ->
-	  let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in
+	  let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
 	  (Fv.union fv1 fv2, Typed.Xml (e1,e2))
       | Dot (e,l) ->
-	  let (fv,e) = expr glb e in
+	  let (fv,e) = expr loc glb e in
 	  (fv,  Typed.Dot (e,l))
       | RecordLitt r -> 
 	  let fv = ref Fv.empty in
 	  let r  = List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r in
 	  let r = List.map 
 		    (fun (l,e) -> 
-		       let (fv2,e) = expr glb e in fv := Fv.union !fv fv2; (l,e))
+		       let (fv2,e) = expr loc glb e 
+		       in fv := Fv.union !fv fv2; (l,e))
 		    r in
 	  let rec check = function
 	    | (l1,_) :: (l2,_) :: _ when l1 = l2 -> 
@@ -401,20 +406,20 @@ let rec expr glb { loc = loc; descr = d } =
 	  check r;
 	  (!fv, Typed.RecordLitt r)
       | Op (op,le) ->
-	  let (fvs,ltes) = List.split (List.map (expr glb) le) in
+	  let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
 	  let fv = List.fold_left Fv.union Fv.empty fvs in
 	  (fv, Typed.Op (op,ltes))
       | Match (e,b) -> 
-	  let (fv1,e) = expr glb e
-	  and (fv2,b) = branches glb b in
+	  let (fv1,e) = expr loc glb e
+	  and (fv2,b) = branches loc glb b in
 	  (Fv.union fv1 fv2, Typed.Match (e, b))
       | Map (e,b) ->
-	  let (fv1,e) = expr glb e
-	  and (fv2,b) = branches glb b in
+	  let (fv1,e) = expr loc glb e
+	  and (fv2,b) = branches loc glb b in
 	  (Fv.union fv1 fv2, Typed.Map (e, b))
       | Try (e,b) ->
-	  let (fv1,e) = expr glb e
-	  and (fv2,b) = branches glb b in
+	  let (fv1,e) = expr loc glb e
+	  and (fv2,b) = branches loc glb b in
 	  (Fv.union fv1 fv2, Typed.Try (e, b))
   in
   fv,
@@ -423,12 +428,12 @@ let rec expr glb { loc = loc; descr = d } =
     Typed.exp_descr = td;
   }
 	      
-  and branches glb b = 
+  and branches loc glb b = 
     let fv = ref Fv.empty in
     let accept = ref Types.empty in
     let b = List.map 
 	      (fun (p,e) ->
-		 let (fv2,e) = expr glb e in
+		 let (fv2,e) = expr loc glb e in
 		 let p = pat glb p in
 		 let fv2 = List.fold_right Fv.remove (Patterns.fv p) fv2 in
 		 fv := Fv.union !fv fv2;
@@ -446,6 +451,8 @@ let rec expr glb { loc = loc; descr = d } =
      } 
     )
 
+let expr = expr noloc
+
 let let_decl glb p e =
   let (_,e) = expr glb e in
   { Typed.let_pat = pat glb p;