Commit 0f6bf435 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-24 17:25:48 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-24 17:25:48+00:00
parent 5afe3e5f
......@@ -707,20 +707,20 @@ struct
record: ((Types.label, node sl) sm) line;
}
type nnf = Types.descr * node sl
type 'a nline = (result * 'a) list
type record =
[ `Success
| `Fail
| `Dispatch of (nf * record) list
| `Label of Types.label * (nf * record) list * record ]
| `Dispatch of (nnf * record) list
| `Label of Types.label * (nnf * record) list * record ]
type t = {
nfv : fv;
ncatchv: fv;
na : Types.descr;
nbasic : Types.descr nline;
nprod : (nf * nf) nline;
nxml : (nf * nf) nline;
nprod : (nnf * nnf) nline;
nxml : (nnf * nnf) nline;
nrecord: record nline
}
......@@ -870,7 +870,7 @@ struct
| Constant (x,c) -> constant x c
| Record (l,p) -> record acc l p
let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any
let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
let normal nf =
let basic =
......@@ -878,8 +878,7 @@ struct
and prod ?kind l =
let line accu (((res,(pl,ql)),acc)) =
let p = bigcap pl and q = bigcap ql in
let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in
let t = Types.Product.normal ?kind acc in
List.fold_left aux accu t in
List.fold_left line [] l
......@@ -891,18 +890,17 @@ struct
| (`Success, []) -> `Success
| (`Fail,_) -> `Fail
| (`Success, (l2,pl)::fields) ->
`Label (l2, [bigcap pl, aux nr fields], `Fail)
`Label (l2, [(Types.any,pl), aux nr fields], `Fail)
| (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
`Label (l2, [bigcap pl, aux nr fields], `Fail)
`Label (l2, [(Types.any,pl), aux nr fields], `Fail)
| (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
let p = bigcap pl in
let pr =
List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
List.map (fun (t,x) -> ((t,pl), aux x fields)) pr in
`Label (l1, pr, `Fail)
| (`Label (l1, pr, ab),_) ->
let aux_ab = aux ab fields in
let pr =
List.map (fun (t,x) -> (constr t,
List.map (fun (t,x) -> ((t,[]),
(* Types.Record.normal enforce physical equility
in case of a ? field *)
if x==ab then aux_ab else
......@@ -1197,10 +1195,15 @@ struct
let unselect = Array.create (Array.length pl) [] in
let aux i x =
let yes, no = f x in
List.iter (fun (p,info) ->
List.iter (fun ( (ty,pl), info) ->
let p =
List.fold_left (fun a p -> Normal.cap a
(Normal.nf (descr p)))
(Normal.constr ty) pl in
let p = Normal.restrict t p in
let p = Normal.normal p in
accu := (p,[i, info]) :: !accu;
accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
) yes;
unselect.(i) <- no @ unselect.(i) in
Array.iteri (fun i -> List.iter (aux i)) pl;
......@@ -1210,7 +1213,7 @@ struct
let disp = dispatcher t (Array.map fst sorted) in
let result (t,_,m) =
let selected = Array.create (Array.length pl) [] in
let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
d t selected unselect
in
......@@ -1222,9 +1225,9 @@ struct
let (_,brs) =
List.fold_left
(fun (t,brs) (p,e) ->
let p = Normal.restrict t (Normal.nf p) in
let t = Types.diff t (p.Normal.a) in
(t, (p,(p.Normal.catchv,e)) :: brs)
let p' = (t,[p]) in
let t' = Types.diff t (Types.descr (accept p)) in
(t', (p',e) :: brs)
) (t,[]) brs in
let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
......@@ -1235,7 +1238,7 @@ struct
(fun _ pl _ ->
let r = ref None in
let aux = function
| [(res,(catchv,e))] -> assert (!r = None);
| [(res,catchv,e)] -> assert (!r = None);
let catchv = List.map (fun v -> (v,-1)) catchv in
r := Some (SortedMap.union_disj catchv res,e)
| [] -> () | _ -> assert false in
......@@ -1261,12 +1264,12 @@ struct
and dispatch_prod1 disp t t1 pl _ =
let t = Types.Product.restrict_1 t t1 in
get_tests pl
(fun (ret1, (res,q)) -> [q, (ret1,res)], [] )
(fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] )
(Types.Product.pi2 t)
(dispatch_prod2 disp t)
(fun x -> detect_right_tail_call (combine x))
and dispatch_prod2 disp t t2 pl _ =
let aux_final (ret2, (ret1, res)) =
let aux_final (ret2, ncatchv, (ret1, res)) =
List.map (conv_source_prod ret1 ret2) res in
return disp pl aux_final
......@@ -1386,7 +1389,7 @@ struct
combine_record l present absent
and dispatch_record_field l disp t plabs tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, (res, catch, rem)) =
let aux (ret, ncatchv, (res, catch, rem)) =
let catch = if ret = [] then catch else (l,ret) :: catch in
(res, catch, rem) in
let pl = Array.map (List.map aux) pl in
......
......@@ -84,6 +84,6 @@ module Compile: sig
val show : Format.formatter -> Types.descr -> normal array -> unit
val make_branches :
Types.descr -> (descr * 'a) list ->
Types.descr -> (node * 'a) list ->
dispatcher * ((capture, int) SortedMap.t * 'a) array
end
......@@ -75,7 +75,7 @@ let dispatcher brs =
match brs.br_compiled with
| Some d -> d
| None ->
let aux b = Patterns.descr b.br_pat, b.br_body in
let aux b = b.br_pat, b.br_body in
let x = Patterns.Compile.make_branches
brs.br_typ
(List.map aux brs.br_branches) in
......@@ -88,7 +88,7 @@ let dispatcher_let_decl l =
| None ->
let comp = Patterns.Compile.make_branches
(Types.descr (Patterns.accept l.let_pat))
[ Patterns.descr l.let_pat, () ] in
[ l.let_pat, () ] in
let x = match comp with
| (disp, [| l, () |]) -> (disp,l)
| _ -> assert false
......
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