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

Original author: cvscast
Date: 2003-05-25 12:00:22+00:00

parser/parser.ml

@@ -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 -> 

runtime/eval.ml

@@ -15,48 +15,48 @@ let enter_global x v =
 
 (* Evaluation of expressions *)
 
-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.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.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 (_,_) -> 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.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)
-    | 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)
+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.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
+  | 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 (_,_) -> 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) -> 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)
+  | 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)
+
+
+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
@@ -72,9 +72,10 @@ and eval_branches env brs arg =
   match rhs.(code) with 
     | Patterns.Compile.Match (bind,e) ->
 	let env = 
-	  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
+	  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
     | Patterns.Compile.Fail -> Value.Absent
 
@@ -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)