Commit 52770e6a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-24 20:44:12 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-24 20:44:13+00:00
parent efb4646c
......@@ -109,10 +109,7 @@ let debug ppf = function
Format.fprintf ppf "[DEBUG:compile]@\n";
let t = Typer.typ !glb_env t
and pl = List.map (Typer.pat !glb_env) pl in
let pl = Array.of_list
(List.map (fun p -> Patterns.Compile.normal
(Patterns.descr p)) pl) in
Patterns.Compile.show ppf (Types.descr t) pl
Patterns.Compile.debug_compile ppf t pl
| `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n";
let t = Types.descr (Typer.typ !glb_env t) in
......
......@@ -684,7 +684,37 @@ let restrict ((a,fv,_) as p) t =
(* Normal forms for patterns and compilation *)
module Normal =
module Normal : sig
type 'a sl = 'a SortedList.t
type ('a,'b) sm = ('a,'b) SortedMap.t
type source =
[ `Catch | `Const of Types.const
| `Left | `Right | `Recompose
| `Field of Types.label
]
type result = (capture, source) sm
type nnf = node sl * Types.descr
type 'a nline = (result * 'a) list
type record =
[ `Success
| `Fail
| `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 : (nnf * nnf) nline;
nxml : (nnf * nnf) nline;
nrecord: record nline
}
val any_basic: Types.descr
val normal: Types.descr -> node list -> t
end =
struct
type 'a sl = 'a SortedList.t
type ('a,'b) sm = ('a,'b) SortedMap.t
......@@ -707,8 +737,9 @@ struct
record: ((Types.label, node sl) sm) line;
}
type nnf = Types.descr * node sl
type 'a nline = (result * 'a) list
type nnf = node sl * Types.descr (* pl,t; t <= \accept{pl} *)
type 'a nline = (result * 'a) sl
type record =
[ `Success
| `Fail
......@@ -724,6 +755,72 @@ struct
nrecord: record nline
}
let nempty = { nfv = []; ncatchv = []; na = Types.empty;
nbasic = []; nprod = []; nxml = []; nrecord = [] }
let ncup nf1 nf2 =
(* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
(* assert (nf1.nfv = nf2.nfv); *)
{ nfv = nf1.nfv;
ncatchv = SortedList.cap nf1.ncatchv nf2.ncatchv;
na = Types.cup nf1.na nf2.na;
nbasic = SortedList.cup nf1.nbasic nf2.nbasic;
nprod = SortedList.cup nf1.nprod nf2.nprod;
nxml = SortedList.cup nf1.nxml nf2.nxml;
nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
}
let fus = SortedMap.union_disj
let slcup = SortedList.cup
let double_fold f l1 l2 =
SortedList.from_list
(List.fold_left
(fun accu x1 ->
List.fold_left
(fun accu x2 ->
f accu x1 x2
)
accu l2
) [] l1)
let ncap nf1 nf2 =
let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu else
let s = Types.cap s1 s2 in
if Types.is_empty s then accu else
(fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
in
let basic accu (res1,t1) (res2,t2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu else
(fus res1 res2, t) :: accu
in
{ nfv = SortedList.cup nf1.nfv nf2.nfv;
ncatchv = SortedList.cup nf1.ncatchv nf2.ncatchv;
na = Types.cap nf1.na nf2.na;
nbasic = double_fold basic nf1.nbasic nf2.nbasic;
nprod = double_fold prod nf1.nprod nf2.nprod;
nxml = double_fold prod nf1.nxml nf2.nxml;
nrecord = []; (* TODO ... *)
}
let ntimes acc p q =
let src_p = List.map (fun v -> (v,`Left)) p.fv
and src_q = List.map (fun v -> (v,`Right)) q.fv in
let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in
let rects = Types.Product.normal acc in
let prod = List.map (fun (t1,t2) -> (src, (([p],t1),([q],t2)))) rects in
{ nempty with
nfv = SortedList.cup p.fv q.fv;
na = acc;
nprod = SortedList.from_list prod
}
let empty = { v = []; catchv = [];
a = Types.empty;
basic = []; prod = []; xml = []; record = [] }
......@@ -747,8 +844,6 @@ struct
record = filter nf.record;
}
let fus = SortedMap.union_disj
let slcup = SortedList.cup
let cap nf1 nf2 =
let merge f lines1 lines2 =
......@@ -870,15 +965,13 @@ struct
| Constant (x,c) -> constant x c
| Record (l,p) -> record acc l p
let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
let normal nf =
let basic =
List.map (fun ((res,()),acc) -> (res,acc))
and prod ?kind l =
let line accu (((res,(pl,ql)),acc)) =
let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in
let aux accu (t1,t2) = (res,( (pl,t1), (ql,t2) ))::accu in
let t = Types.Product.normal ?kind acc in
List.fold_left aux accu t in
List.fold_left line [] l
......@@ -890,17 +983,17 @@ struct
| (`Success, []) -> `Success
| (`Fail,_) -> `Fail
| (`Success, (l2,pl)::fields) ->
`Label (l2, [(Types.any,pl), aux nr fields], `Fail)
`Label (l2, [(pl,Types.any), aux nr fields], `Fail)
| (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
`Label (l2, [(Types.any,pl), aux nr fields], `Fail)
`Label (l2, [(pl,Types.any), aux nr fields], `Fail)
| (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
let pr =
List.map (fun (t,x) -> ((t,pl), aux x fields)) pr in
List.map (fun (t,x) -> (((pl,t) : nnf), 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) -> ((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
......@@ -927,6 +1020,9 @@ struct
nrecord = nlines (record nf.record);
}
let normal t pl =
normal (List.fold_left (fun a p -> cap a (nf (descr p))) (constr t) pl)
end
......@@ -1195,14 +1291,8 @@ struct
let unselect = Array.create (Array.length pl) [] in
let aux i x =
let yes, no = f x in
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
List.iter (fun ( (pl,ty), info) ->
let p = Normal.normal ty pl in
accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
) yes;
unselect.(i) <- no @ unselect.(i) in
......@@ -1225,7 +1315,7 @@ struct
let (_,brs) =
List.fold_left
(fun (t,brs) (p,e) ->
let p' = (t,[p]) in
let p' = ([p],t) in
let t' = Types.diff t (Types.descr (accept p)) in
(t', (p',e) :: brs)
) (t,[]) brs in
......@@ -1590,9 +1680,11 @@ struct
queue disp;
print_dispatchers ppf
type normal = Normal.t
let normal p = Normal.normal (Normal.nf p)
let debug_compile ppf t pl =
let pl = Array.of_list
(List.map (fun p -> Normal.normal Types.any [p]) pl) in
let t = Types.descr t in
show ppf t pl
end
......@@ -46,11 +46,7 @@ end
(* Pattern matching: compilation *)
module Compile: sig
type normal
val normal : descr -> normal
type dispatcher
val dispatcher: Types.descr -> normal array -> dispatcher
type actions =
[ `Ignore of result
......@@ -81,9 +77,9 @@ module Compile: sig
val actions: dispatcher -> actions
val show : Format.formatter -> Types.descr -> normal array -> unit
val make_branches :
Types.descr -> (node * 'a) list ->
dispatcher * ((capture, int) SortedMap.t * 'a) array
val debug_compile : Format.formatter -> Types.node -> node list -> unit
end
......@@ -24,13 +24,13 @@ type pair_kind = [ `Normal | `XML ]
module I = struct
type 'a t = {
ints : Intervals.t;
atoms : atom Atoms.t;
ints : Intervals.t;
chars : Chars.t;
times : ('a * 'a) Boolean.t;
xml : ('a * 'a) Boolean.t;
arrow : ('a * 'a) Boolean.t;
record: (label * bool * 'a) Boolean.t;
chars : Chars.t;
}
let empty = {
......
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