Commit 02a96b54 authored by Pietro Abate's avatar Pietro Abate

[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
parent 57aef957
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment