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