[r2002-10-30 03:08:01 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-30 03:08:09+00:00

driver/cduce.ml

@@ -39,6 +39,9 @@ let rec print_exn ppf = function
 	    l1 c1 l2 c2
       );
       print_exn ppf exn
+  | Value.CDuceExn v ->
+      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
+        Value.print v
   | Typer.WrongLabel (t,l) ->
       Format.fprintf ppf "Wrong record selection: the label %s@\n" 
         (Types.label_name l);

parser/ast.ml

@@ -39,6 +39,10 @@ and pexpr' =
   | Match of pexpr * branches
   | Map of pexpr * branches
   | Dot of (pexpr* Types.label)
+
+  (* Exceptions *)
+  | Try of pexpr * branches
+
 and abstr = { 
   fun_name : string option; 
   fun_iface : (ppat * ppat) list;

parser/parser.ml

@@ -58,6 +58,11 @@ EXTEND
   expr: [
     "top" RIGHTA
     [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
+    | "try"; e = SELF; "with"; b = branches -> 
+	let default = 
+	  (mk noloc (Capture "x"),
+	   mk noloc (Op ("raise",[mk noloc (Var "x")]))) in
+	mk loc (Try (e,b@[default]))
     | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
     | "transform"; e = SELF; "with"; b = branches -> 
 	mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
@@ -83,6 +88,7 @@ EXTEND
     |
     [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
     | LIDENT "load_xml"; e = expr -> mk loc (Op ("load_xml",[e]))
+    | LIDENT "raise"; e = expr -> mk loc (Op ("raise",[e]))
     | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
     ]
 

runtime/value.ml

 module Env = Map.Make (struct type t = string let compare = compare end)
 let empty_env = Env.empty
 
+
 type t =
   | Pair of t * t
   | Record of (Types.label,t) SortedMap.t
@@ -16,6 +17,8 @@ and abstr = {
   fun_body  : Typed.branches;
 }
 
+exception CDuceExn of t
+
 let rec is_seq = function
   | Pair (_, y) when is_seq y -> true
   | Atom a when a = Sequence.nil_atom -> true
@@ -318,6 +321,9 @@ let rec eval env e0 =
     | 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.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
+    | Typed.Try (arg,brs) -> 
+	(try eval env arg with CDuceExn v -> eval_branches env brs v)
     | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
     | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
     | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
@@ -327,7 +333,7 @@ let rec eval env e0 =
     | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
     | Typed.Dot (e, l) -> eval_dot l (eval env e)
     | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
-    | _ -> failwith "Unknown expression"
+    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
 
 
 and eval_apply f arg = match f with

runtime/value.mli

@@ -2,6 +2,8 @@ type t
 and abstr
 and env
 
+exception CDuceExn of t
+
 val empty_env : env
 
 val print: Format.formatter -> t -> unit

typing/typed.ml

@@ -37,6 +37,9 @@ and  texpr' =
   | Match of texpr * branches
   | Map of texpr * branches
   | Dot of (texpr * Types.label)
+      
+  (* Exception *)
+  | Try of texpr * branches
 
 and abstr = { 
   fun_name : string option; 

typing/typer.ml

@@ -363,6 +363,10 @@ let rec expr { loc = loc; descr = d } =
 	  let (fv1,e) = expr e
 	  and (fv2,b) = branches b in
 	  (Fv.union fv1 fv2, Typed.Map (e, b))
+      | Try (e,b) ->
+	  let (fv1,e) = expr e
+	  and (fv2,b) = branches b in
+	  (Fv.union fv1 fv2, Typed.Try (e, b))
   in
   fv,
   { Typed.exp_loc = loc;
@@ -426,12 +430,18 @@ and type_check' loc env e constr precise = match e with
 	| Some f -> Env.add f a.fun_typ env in
       List.iter 
 	(fun (t1,t2) ->
-	   ignore (type_check_branches loc env t1 a.fun_body t2 false)
+	   ignore (type_check_branches loc env true t1 a.fun_body t2 false)
 	) a.fun_iface;
       t
+
   | Match (e,b) ->
       let t = type_check env e b.br_accept true in
-      type_check_branches loc env t b constr precise
+      type_check_branches loc env true t b constr precise
+
+  | Try (e,b) ->
+      let te = type_check env e constr precise in
+      let tb = type_check_branches loc env false Types.any b constr precise in
+      Types.cup te tb
 
   | Pair (e1,e2) -> 
       let rects = Types.Product.get constr in
@@ -493,7 +503,7 @@ and type_check' loc env e constr precise = match e with
       let res = 
 	Sequence.map 
 	  (fun t -> 
-	     type_check_branches loc env t b constr' (precise || (not exact)))
+	     type_check_branches loc env true t b constr' (precise || (not exact)))
 	  t in
       if not exact then check loc res constr "";
       if precise then res else constr
@@ -560,7 +570,7 @@ and compute_type' loc env = function
       type_op loc op args
   | Map (e,b) ->
       let t = compute_type env e in
-      Sequence.map (fun t -> type_check_branches loc env t b Types.any true) t
+      Sequence.map (fun t -> type_check_branches loc env true t b Types.any true) t
 
 (* We keep these cases here to allow comparison and benchmarking ...
    Just comment the corresponding cases in type_check' to
@@ -581,24 +591,24 @@ and compute_type' loc env = function
 
   | _ -> assert false
 
-and type_check_branches loc env targ brs constr precise =
+and type_check_branches loc env exh targ brs constr precise =
   if Types.is_empty targ then Types.empty 
   else (
     brs.br_typ <- Types.cup brs.br_typ targ;
-    branches_aux loc env targ 
+    branches_aux loc env exh targ 
       (if precise then Types.empty else constr) 
       constr precise brs.br_branches
   )
     
-and branches_aux loc env targ tres constr precise = function
-  | [] -> raise_loc loc (NonExhaustive targ)
+and branches_aux loc env exh targ tres constr precise = function
+  | [] -> if exh then raise_loc loc (NonExhaustive targ) else tres
   | b :: rem ->
       let p = b.br_pat in
       let acc = Types.descr (Patterns.accept p) in
 
       let targ' = Types.cap targ acc in
       if Types.is_empty targ' 
-      then branches_aux loc env targ tres constr precise rem
+      then branches_aux loc env exh targ tres constr precise rem
       else 
 	( b.br_used <- true;
 	  let res = Patterns.filter targ' p in
@@ -609,7 +619,7 @@ and branches_aux loc env targ tres constr precise = function
 	  let tres = if precise then Types.cup t tres else tres in
 	  let targ'' = Types.diff targ acc in
 	  if (Types.non_empty targ'') then 
-	    branches_aux loc env targ'' tres constr precise rem 
+	    branches_aux loc env exh targ'' tres constr precise rem 
 	  else
 	    tres
 	)
@@ -634,6 +644,8 @@ and type_op loc op args =
 	check loc1 t1 Sequence.string
 	  "The argument of load_xml must be a string (filename)";
 	Types.any
+    | "raise", [loc1,t1] ->
+	Types.empty
     | _ -> assert false
 
 and type_int_binop f loc1 t1 loc2 t2 =