[r2003-05-10 18:31:04 by cvscast] Special nodes to locate expressions

Original author: cvscast
Date: 2003-05-10 18:31:04+00:00

driver/cduce.ml

@@ -163,7 +163,7 @@ let run ppf ppf_err input =
 	  let v = Eval.eval Eval.Env.empty e in
 	  if not !quiet then
 	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
-      | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
+      | Ast.LetDecl (p,Ast.Abstraction _) -> ()
       | Ast.LetDecl (p,e) ->
 	  let decl = Typer.let_decl p e in
 	  type_decl decl;
@@ -181,7 +181,7 @@ let run ppf ppf_err input =
     List.iter eval_decl decls
   in
   let rec phrases funs = function
-    | { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs -> 
+    | { descr = Ast.LetDecl (p,(Ast.Abstraction _ as e)) } :: phs -> 
 	phrases ((p,e)::funs) phs
     | ph :: phs ->
 	do_fun_decls funs;
@@ -201,7 +201,7 @@ let run ppf ppf_err input =
       List.fold_left
 	(fun ((typs,funs) as accu) ph -> match ph.descr with
 	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
-	   | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) -> 
+	   | Ast.LetDecl (p,(Ast.Abstraction _ as e)) -> 
 	       (typs, (p,e)::funs)
 	   | _ -> accu
 	) ([],[]) p in

parser/ast.ml

@@ -23,9 +23,11 @@ and debug_directive =
   ]
 
 
-and pexpr = pexpr' located
-and pexpr' = 
+and pexpr = 
+  | LocatedExpr of loc * pexpr
+
   | Forget of pexpr * ppat    
+
   (* CDuce is a Lambda-calculus ... *)
   | Var of id
   | Apply of pexpr * pexpr

parser/location.ml

@@ -101,6 +101,7 @@ type 'a located = { loc : loc; descr : 'a }
 let mk (i,j) x = { loc = (!source,i,j); descr = x }
 let mk_loc loc x = { loc = loc; descr = x }
 let mknoloc x = { loc = noloc; descr = x }
+let loc_of_pos (i,j) = (!source,i,j)
 
 let protect ppf f =
   match !viewport with

parser/location.mli

@@ -33,6 +33,8 @@ val mk: int * int -> 'a -> 'a located
 val mk_loc: loc -> 'a -> 'a located
 val mknoloc: 'a -> 'a located
 
+val loc_of_pos : int * int -> loc
+
 
 (* Are we working in a protected environement (web prototype ...) ? *)
 val set_protected : bool -> unit

parser/parser.ml

@@ -15,25 +15,26 @@ let pat     = Grammar.Entry.create gram "type/pattern expression"
 let regexp  = Grammar.Entry.create gram "type/pattern regexp"
 let const   = Grammar.Entry.create gram "scalar constant"
 		
+let exp pos e = LocatedExpr (loc_of_pos pos,e)
+
 let rec multi_prod loc = function
   | [ x ] -> x
   | x :: l -> mk loc (Prod (x, multi_prod loc l))
   | [] -> assert false
       
-let rec tuple loc = function
+let rec tuple = function
   | [ x ] -> x
-  | x :: l -> mk loc (Pair (x, tuple loc l))
+  | x :: l -> Pair (x, tuple l)
   | [] -> assert false
 
 let tuple_queue = 
-  List.fold_right (fun x q -> mk_loc x.loc (Pair (x, q)))
-
+  List.fold_right (fun x q -> Pair (x, q))
 
 
 let char = mknoloc (Internal (Types.char Chars.any))
 let string_regexp = Star (Elem char)
 	       
-let cst_nil =  mknoloc (Cst (Types.Atom Sequence.nil_atom))
+let cst_nil =  Cst (Types.Atom Sequence.nil_atom)
 		 
 let seq_of_string pos s =
   let s =  Encodings.Utf8.mk s in
@@ -61,7 +62,7 @@ let parse_char loc s =
 
 let char_list pos s = 
   let s = seq_of_string pos s in
-  List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_int c)))) s
+  List.map (fun (loc,c) -> exp loc (Cst (Types.Char (Chars.mk_int c)))) s
 
 
 let include_stack = ref []
@@ -76,7 +77,7 @@ EXTEND
   phrase: [
     [ (p,e) = let_binding -> [ mk loc (LetDecl (p,e)) ]
     | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
-        [ mk loc (EvalStatement (mk loc (Match (e1,[p,e2])))) ]
+        [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
     | LIDENT "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
     | LIDENT "debug"; d = debug_directive -> [ mk loc (Debug d) ]
     | LIDENT "include"; s = STRING2 ->
@@ -111,27 +112,27 @@ EXTEND
 
   expr: [
     "top" RIGHTA
-    [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
+    [ "match"; e = SELF; "with"; b = branches -> exp loc (Match (e,b))
     | "try"; e = SELF; "with"; b = branches -> 
 	let default = 
-	  (mknoloc (Capture (ident "x")),
-	   mknoloc (Op ("raise",[mknoloc (Var (ident "x"))]))) in
-	mk loc (Try (e,b@[default]))
-    | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
-    | "ttree"; e = SELF; "with"; b = branches -> mk loc (Ttree (e,b))
+	  mknoloc (Capture (ident "x")), 
+	  Op ("raise",[Var (ident "x")]) in
+	exp loc (Try (e,b@[default]))
+    | "map"; e = SELF; "with"; b = branches -> exp loc (Map (e,b))
+    | "ttree"; e = SELF; "with"; b = branches -> exp loc (Ttree (e,b))
     | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
 	let p1 = mk loc (Internal (Builtin.true_type))
 	and p2 = mk loc (Internal (Builtin.false_type)) in
-	mk loc (Match (e, [p1,e1; p2,e2]))
+	exp loc (Match (e, [p1,e1; p2,e2]))
     | "transform"; e = SELF; "with"; b = branches -> 
 	let default = mknoloc (Capture (ident "x")), cst_nil in
-	mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
+	exp loc (Op ("flatten", [Map (e,b@[default])]))
     | "fun"; (f,a,b) = fun_decl ->
-	mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
+	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
     | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
-        mk loc (Match (e1,[p,e2]))
+        exp loc (Match (e1,[p,e2]))
     | e = expr; ":"; p = pat ->
-	mk loc (Forget (e,p))
+	exp loc (Forget (e,p))
     ]
 
     
@@ -141,17 +142,17 @@ EXTEND
 	  | "<<" -> "<"
 	  | ">>" -> ">"
 	  | s -> s in
-	mk loc (Op (op,[e1;e2]))
+	exp loc (Op (op,[e1;e2]))
     ]
 
     | 
     [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> 
-	mk loc (Op (op,[e1;e2]))
+	exp loc (Op (op,[e1;e2]))
     | e = expr; "\\"; l = [LIDENT | UIDENT] -> 
-	mk loc (RemoveField (e,LabelPool.mk l)) 
+	exp loc (RemoveField (e,LabelPool.mk l)) 
     ]
     |
-    [ e1 = expr; op = ["*"]; e2 = expr -> mk loc (Op (op,[e1;e2]))  
+    [ e1 = expr; op = ["*"]; e2 = expr -> exp loc (Op (op,[e1;e2]))  
     | e = expr; op = "/"; p = pat ->
 
 	let tag = mk loc (Internal (Types.atom (Atoms.any))) in
@@ -160,12 +161,12 @@ EXTEND
 	let re = Star(Alt(SeqCapture(ident "x",Elem p), Elem any)) in
 	let ct = mk loc (Regexp (re,any)) in
         let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
-	let b = (p,  mk loc (Var (ident "x"))) in
-	mk loc (Op ("flatten", [mk loc (Map (e,[b]))]))
+	let b = (p,  Var (ident "x")) in
+	exp loc (Op ("flatten", [Map (e,[b])]))
     ]
     |
     [ e = expr;  "."; l = [LIDENT | UIDENT] -> 
-	mk loc (Dot (e,LabelPool.mk l)) 
+	exp loc (Dot (e,LabelPool.mk l)) 
     ]  
  
     |
@@ -179,34 +180,34 @@ EXTEND
 	   | LIDENT "int_of"
 	   | LIDENT "string_of"
 	   ]; 
-      e = expr -> mk loc (Op (op,[e]))
+      e = expr -> exp loc (Op (op,[e]))
     | op = [ LIDENT "dump_to_file" ];
-      e1 = expr LEVEL "no_appl"; e2 = expr -> mk loc (Op (op, [e1;e2])) 
-    | e1 = SELF; LIDENT "div"; e2 = expr -> mk loc (Op ("/", [e1;e2]))
-    | e1 = SELF; LIDENT "mod"; e2 = expr -> mk loc (Op ("mod", [e1;e2]))
-    | e1 = SELF; e2 = expr -> mk loc (Apply (e1,e2))
+      e1 = expr LEVEL "no_appl"; e2 = expr -> exp loc (Op (op, [e1;e2])) 
+    | e1 = SELF; LIDENT "div"; e2 = expr -> exp loc (Op ("/", [e1;e2]))
+    | e1 = SELF; LIDENT "mod"; e2 = expr -> exp loc (Op ("mod", [e1;e2]))
+    | e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
     ]
 
     | "no_appl" 
-    [ c = const -> mk loc (Cst c)
-    | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
+    [ c = const -> exp loc (Cst c)
+    | "("; l = LIST1 expr SEP ","; ")" -> exp loc (tuple l)
     | "[";  l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; "]" ->
 	let e = match e with Some e -> e | None -> cst_nil in
 	List.fold_right 
 	  (fun x q ->
 	     match x with
 	       | `Elems l -> tuple_queue l q
-	       | `Explode x -> mk_loc x.loc (Op ("@",[x;q]))
+	       | `Explode x -> Op ("@",[x;q])
 	  ) l e
     | t = [ a = TAG -> 
-	      mk loc (Cst (Types.Atom (Atoms.mk a)))
+	      exp loc (Cst (Types.Atom (Atoms.mk a)))
 	  | "<"; e = expr LEVEL "no_appl" -> e ];
 	a = expr_attrib_spec; ">"; c = expr ->
-	mk loc (Xml (t, mk loc (Pair (a,c))))
-    | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt LabelMap.empty) ]; "}" -> r
+	exp loc (Xml (t, Pair (a,c)))
+    | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
     | s = STRING2 ->
-	tuple loc (char_list loc s @ [cst_nil])
-    | a = LIDENT -> mk loc (Var (ident a))
+	exp loc (tuple (char_list loc s @ [cst_nil]))
+    | a = LIDENT -> exp loc (Var (ident a))
     ]
 
   ];
@@ -220,14 +221,14 @@ EXTEND
 	  
   let_binding: [
     [ "let"; p = pat; "="; e = expr -> (p,e)
-    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mknoloc (Forget (e,t)))
+    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, Forget (e,t))
     | "let"; "fun"; (f,a,b) = fun_decl ->
 	let p = match f with 
 	  | Some x -> mk loc (Capture x)
 	  | _ -> failwith "Function name mandatory in let fun declarations"
 	in
 	let abst = { fun_name = f; fun_iface = a; fun_body = b } in
-        let e = mk loc (Abstraction abst) in
+        let e = exp loc (Abstraction abst) in
         (p,e);
     ] 
   ];
@@ -403,13 +404,13 @@ EXTEND
 	      [ l = [LIDENT | UIDENT]; "="; x = expr -> 
 		  (LabelPool.mk l,x) ] 
 	      SEP ";" ->
-	  mk loc (RecordLitt (make_record loc r))
+	  exp loc (RecordLitt (make_record loc r))
       ] ];
   
   expr_attrib_spec:
     [ [ r = expr_record_spec -> r ]
     | [ e = expr LEVEL "no_appl" -> e 
-      | -> mk loc (RecordLitt (LabelMap.empty)) 
+      | -> exp loc (RecordLitt (LabelMap.empty)) 
       ] 
     ];
 END

typing/typer.ml

@@ -484,95 +484,98 @@ let all_branches = ref []
 (* IDEA: introduce a node Loc in the AST to override nolocs
    in sub-expressions *)
    
-let rec expr loc' { 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 loc e and t = typ t in
-	  (fv, Typed.Forget (e,t))
-      | Var s -> (Fv.singleton s, Typed.Var s)
-      | Apply (e1,e2) -> 
-	  let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
-	  (Fv.cup fv1 fv2, Typed.Apply (e1,e2))
-      | Abstraction a ->
-	  let iface = List.map (fun (t1,t2) -> (typ t1, typ t2)) 
-			a.fun_iface in
-	  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 loc a.fun_body in
-	  let fv = match a.fun_name with
-	    | None -> fv0
-	    | Some f -> Fv.remove f fv0 in
-	  (fv,
-	   Typed.Abstraction 
-	     { Typed.fun_name = a.fun_name;
-	       Typed.fun_iface = iface;
-	       Typed.fun_body = body;
-	       Typed.fun_typ = t;
-	       Typed.fun_fv = fv
-	     }
-	  )
-      | Cst c -> (Fv.empty, Typed.Cst c)
-      | Pair (e1,e2) ->
-	  let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
-	  (Fv.cup fv1 fv2, Typed.Pair (e1,e2))
-      | Xml (e1,e2) ->
-	  let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
-	  (Fv.cup fv1 fv2, Typed.Xml (e1,e2))
-      | Dot (e,l) ->
-	  let (fv,e) = expr loc e in
-	  (fv,  Typed.Dot (e,l))
-      | RemoveField (e,l) ->
-	  let (fv,e) = expr loc e in
-	  (fv,  Typed.RemoveField (e,l))
-      | RecordLitt r -> 
-	  let fv = ref Fv.empty in
-	  let r = LabelMap.map 
-		    (fun e -> 
-		       let (fv2,e) = expr loc e 
-		       in fv := Fv.cup !fv fv2; e)
-		    r in
-	  (!fv, Typed.RecordLitt r)
-      | Op (op,le) ->
-	  let (fvs,ltes) = List.split (List.map (expr loc) le) in
-	  let fv = List.fold_left Fv.cup Fv.empty fvs in
-	  (fv, Typed.Op (op,ltes))
-      | Match (e,b) -> 
-	  let (fv1,e) = expr loc e
-	  and (fv2,b) = branches loc b in
-	  (Fv.cup fv1 fv2, Typed.Match (e, b))
-      | Map (e,b) ->
-	  let (fv1,e) = expr loc e
-	  and (fv2,b) = branches loc b in
-	  (Fv.cup fv1 fv2, Typed.Map (e, b))
-      | Ttree (e,b) ->
-	  let b = b @ [ (mknoloc (Internal Types.any)), mknoloc MatchFail ] in
-	  let (fv1,e) = expr loc e
-	  and (fv2,b) = branches loc b in
-	  (Fv.cup fv1 fv2, Typed.Ttree (e, b))
-      | MatchFail -> (Fv.empty, Typed.MatchFail)
-      | Try (e,b) ->
-	  let (fv1,e) = expr loc e
-	  and (fv2,b) = branches loc b in
-	  (Fv.cup fv1 fv2, Typed.Try (e, b))
-  in
+let exp loc fv e =
   fv,
   { Typed.exp_loc = loc;
     Typed.exp_typ = Types.empty;
-    Typed.exp_descr = td;
+    Typed.exp_descr = e;
   }
+
+
+let rec expr loc = function
+  | LocatedExpr (loc,e) -> expr loc e
+  | Forget (e,t) ->
+      let (fv,e) = expr loc e and t = typ t in
+      exp loc fv (Typed.Forget (e,t))
+  | Var s -> 
+      exp loc (Fv.singleton s) (Typed.Var s)
+  | Apply (e1,e2) -> 
+      let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
+      exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
+  | Abstraction a ->
+      let iface = List.map (fun (t1,t2) -> (typ t1, typ t2)) 
+		    a.fun_iface in
+      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
+	| Some f -> Fv.remove f fv0 in
+      let e = Typed.Abstraction 
+		{ Typed.fun_name = a.fun_name;
+		  Typed.fun_iface = iface;
+		  Typed.fun_body = body;
+		  Typed.fun_typ = t;
+		  Typed.fun_fv = fv
+		} in
+      exp loc fv e
+  | Cst c -> 
+      exp loc Fv.empty (Typed.Cst c)
+  | Pair (e1,e2) ->
+      let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
+      exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))
+  | Xml (e1,e2) ->
+      let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
+      exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
+  | Dot (e,l) ->
+      let (fv,e) = expr loc e in
+      exp loc fv (Typed.Dot (e,l))
+  | RemoveField (e,l) ->
+      let (fv,e) = expr loc e in
+      exp loc fv (Typed.RemoveField (e,l))
+  | RecordLitt r -> 
+      let fv = ref Fv.empty in
+      let r = LabelMap.map 
+		(fun e -> 
+		   let (fv2,e) = expr loc e 
+		   in fv := Fv.cup !fv fv2; e)
+		r in
+      exp loc !fv (Typed.RecordLitt r)
+  | Op (op,le) ->
+      let (fvs,ltes) = List.split (List.map (expr loc) le) in
+      let fv = List.fold_left Fv.cup Fv.empty fvs in
+      exp loc fv (Typed.Op (op,ltes))
+  | Match (e,b) -> 
+      let (fv1,e) = expr loc e
+      and (fv2,b) = branches b in
+      exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))
+  | Map (e,b) ->
+      let (fv1,e) = expr loc e
+      and (fv2,b) = branches b in
+      exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))
+  | Ttree (e,b) ->
+      let b = b @ [ mknoloc (Internal Types.any), MatchFail ] in
+      let (fv1,e) = expr loc e
+      and (fv2,b) = branches b in
+      exp loc (Fv.cup fv1 fv2) (Typed.Ttree (e, b))
+  | MatchFail -> 
+      exp loc (Fv.empty) Typed.MatchFail
+  | Try (e,b) ->
+      let (fv1,e) = expr loc e
+      and (fv2,b) = branches b in
+      exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
+
 	      
-  and branches loc b = 
+  and branches b = 
     let fv = ref Fv.empty in
     let accept = ref Types.empty in
     let branch (p,e) = 
-      let br_loc = merge_loc p.loc e.loc in
-      let (fv2,e) = expr loc e in
+      let (fv2,e) = expr noloc e in
+      let br_loc = merge_loc p.loc e.Typed.exp_loc in
       let p = pat p in
       let fv2 = Fv.diff fv2 (Patterns.fv p) in
       fv := Fv.cup !fv fv2;