Commit 42d62b7e authored by Pietro Abate's avatar Pietro Abate

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

Original author: cvscast
Date: 2002-10-30 03:08:09+00:00
parent c77c6afd
......@@ -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);
......
......@@ -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;
......
......@@ -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))
]
......
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
......
......@@ -2,6 +2,8 @@ type t
and abstr
and env
exception CDuceExn of t
val empty_env : env
val print: Format.formatter -> t -> unit
......
......@@ -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;
......
......@@ -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 =
......
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