Commit ad651c2e authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-05-25 12:00:22 by cvscast] Menage

Original author: cvscast
Date: 2003-05-25 12:00:22+00:00
parent 5869d4b6
......@@ -152,10 +152,7 @@ EXTEND
[ "match"; e = SELF; "with"; b = branches ->
exp loc (Match (e,b))
| "try"; e = SELF; "with"; b = branches ->
let default =
mknoloc (Capture id_dummy),
Op ("raise", [Var id_dummy]) in
exp loc (Try (e,b@[default]))
exp loc (Try (e,b))
| "map"; e = SELF; "with"; b = branches ->
exp loc (Map (e,b))
| "xtransform"; e = SELF; "with"; b = branches ->
......
......@@ -15,43 +15,20 @@ let enter_global x v =
(* Evaluation of expressions *)
let rec eval env e0 =
match e0.Typed.exp_descr with
let rec eval env e0 = match e0.Typed.exp_descr with
| Typed.Forget (e,_) -> eval env e
| Typed.Var s ->
(try Env.find s env
with Not_found -> Env.find s !global_env)
| Typed.Var s -> (try Env.find s env with Not_found -> Env.find s !global_env)
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let env =
IdSet.fold
(fun accu x ->
try Env.add x (Env.find x env) accu
with Not_found -> accu (* global *))
Env.empty a.Typed.fun_fv in
let env_ref = ref env in
let rec self = Abstraction (a.Typed.fun_iface,
eval_branches' env_ref a.Typed.fun_body) in
(match a.Typed.fun_name with
| None -> ()
| Some f -> env_ref := Env.add f self env;
);
self
(* Optimizations:
- for the non-recursive case, use eval_branches
- for the recursive case, could cheat by patching self afterwards:
(Obj.magic self).(1) <- ....
*)
| Typed.Abstraction a -> eval_abstraction env a
| Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
Xml (eval env e1, eval env e2, eval env e3)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> Xml (eval env e1, eval env e2, eval env e3)
| Typed.Xml (_,_) -> assert false
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
| Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
| Typed.Try (arg,brs) -> (try eval env arg with CDuceExn v -> eval_branches env brs v)
| Typed.Try (arg,brs) -> eval_try env arg brs
| Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
......@@ -59,6 +36,29 @@ let rec eval env e0 =
| Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
and eval_try env arg brs =
try eval env arg
with (CDuceExn v) as exn ->
match eval_branches env brs v with
| Value.Absent -> raise exn
| x -> x
and eval_abstraction env a =
let env =
IdSet.fold
(fun accu x ->
try Env.add x (Env.find x env) accu with Not_found -> accu)
Env.empty a.Typed.fun_fv in
let env_ref = ref env in
let self = Abstraction (a.Typed.fun_iface,
eval_branches' env_ref a.Typed.fun_body) in
(match a.Typed.fun_name with
| None -> ()
| Some f -> env_ref := Env.add f self env;
);
self
and eval_apply f arg = match f with
| Abstraction (_,clos) -> clos arg
| _ -> assert false
......@@ -72,7 +72,8 @@ and eval_branches env brs arg =
match rhs.(code) with
| Patterns.Compile.Match (bind,e) ->
let env =
List.fold_left (fun env (x,i) ->
List.fold_left (
fun env (x,i) ->
if (i == -1) then Env.add x arg env
else Env.add x bindings.(i) env) env (IdMap.get bind) in
eval env e
......@@ -82,7 +83,9 @@ and eval_let_decl env l =
let v = eval env l.Typed.let_body in
let (disp,bind) = Typed.dispatcher_let_decl l in
let (_,bindings) = run_dispatcher disp v in
List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)
List.map
(fun (x,i) -> (x, if (i == -1) then v else bindings.(i)))
(IdMap.get bind)
and eval_map env brs = function
| Pair (x,y) ->
......@@ -95,7 +98,10 @@ and eval_map env brs = function
and eval_transform env brs = function
| Pair (x,y) ->
let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
let x =
match eval_branches env brs x with
| Value.Absent -> Value.nil
| x -> x in
concat x (eval_transform env brs y)
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
......
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