Skip to content

GitLab

Commit 00a2455c authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-25 01:12:55 by afrisch] Prepare for records 

Original author: afrisch
Date: 2004-12-25 01:12:55+00:00
parent 21c9f5d7
Hide whitespace changes
Inline Side-by-side
driver/cduce.ml
View file @ 00a2455c
......@@ -218,7 +218,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "[DEBUG:approx]@.";
let t = Typer.typ tenv t in
let p = Typer.pat tenv p in
Patterns.demo ppf (Patterns.descr p) (Types.descr t);
Patterns.demo ppf (Patterns.descr p) (Types.descr t);
(*
let (x,c) = Patterns.approx (Patterns.descr p) (Types.descr t) in
List.iter (fun x -> Format.fprintf ppf "%a=* " U.print (Id.value x)) x;
......@@ -227,7 +227,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "%a=%a "
U.print (Id.value x)
Types.Print.print_const c
) c; *)
) c; *)
Format.fprintf ppf "@."
let flush_ppf ppf = Format.fprintf ppf "@."
......
types/patterns.ml
View file @ 00a2455c
exception Error of string
open Ident
let print_lab ppf l =
if (l == LabelPool.dummy_max)
then Format.fprintf ppf "<dummy_max>"
else Label.print ppf (LabelPool.value l)
(*
To be sure not to use generic comparison ...
*)
......@@ -1627,7 +1632,7 @@ x=(1,2)
else approx_var (NodeSet.add q seen) q.descr t xs
let approx_cst p t xs =
let approx_cst ((a,_,_) as p) t xs =
if IdSet.is_empty xs then IdMap.empty
else
let rec aux accu (x,t) =
......@@ -1636,6 +1641,7 @@ x=(1,2)
| Some c -> (x,c)::accu
| None -> accu
else accu in
let t = Types.cap t a in
IdMap.from_list_disj (List.fold_left aux [] (filter_descr t p))
let approx_var ((a,_,_) as p) t =
......@@ -1731,9 +1737,11 @@ x=(1,2)
| TConj (_,_,l,r) ->
Format.fprintf ppf "(%a & %a)" print l print r
| TRecord (_,_,t,xs,l,q) ->
Format.fprintf ppf "<t=%a;xs=%a;{_}>"
Format.fprintf ppf "<t=%a;xs=%a;{%a=%a}>"
Types.Print.print t
Print.print_xs xs
Label.print (LabelPool.value l)
Print.print q.descr
| TTimes (kind,_,_,t,xs,q1,q2) ->
Format.fprintf ppf "<t=%a;xs=%a;(%a,%a)>"
Types.Print.print t
......@@ -1769,7 +1777,7 @@ x=(1,2)
TRecord ((incr uid; !uid),p, Types.any,fv,l,q)
| Dummy -> assert false
let constr a t =
let constrain a t =
if Types.disjoint a t then TFail
else if Types.subtype t a then TSucceed
else TConstr (a,t)
......@@ -1785,7 +1793,7 @@ x=(1,2)
let xs = IdSet.diff xs (IdMap.domain vs) in
let pr = TargExpr.merge (TargExpr.constants vs) pr in
capt pr (if (IdSet.is_empty xs) then constr a t else f xs)
capt pr (if (IdSet.is_empty xs) then constrain a t else f xs)
let rec optimize t xs = function
......@@ -1804,7 +1812,7 @@ x=(1,2)
conj a1 fv1
(optimize t (IdSet.cap xs fv1) p1)
(optimize (Types.cap t a1) (IdSet.diff xs fv1) p2)
| TConstr (a,_) -> constr a t
| TConstr (a,_) -> constrain a t
| TTimes (kind,uid, p,_,_,q1,q2) ->
factorize p t xs (fun xs -> TTimes (kind,uid, p,t,xs,q1,q2))
| TRecord (uid,p,_,_,l,q) ->
......@@ -1833,6 +1841,61 @@ x=(1,2)
| TTimes (kind,uid,_,t,xs,q1,q2) when k == kind -> (uid,t,xs,q1,q2)::accu
| p -> fold (collect_times k) accu p
let rec collect_record accu = function
| TRecord (uid,_,t,xs,l,q) -> (uid,t,xs,l,q)::accu
| p -> fold collect_record accu p
let opt_all t0 =
List.map
(fun (p,t,xs) ->
if Types.subtype t t0 then (p,t,xs)
else let t = Types.cap t t0 in (optimize t xs p, t, xs))
let get_results reqs =
List.map (fun (p,_,_) -> get_result p) reqs
let collect_all f reqs =
List.fold_left (fun accu (p,_,_) -> f accu p) [] reqs
let prod_all k side pi sel selq reqs =
let extra = ref [] in
let aux3 s1 accu t12 =
let t1 = sel t12 in
if (Types.subtype s1 t1) || (Types.disjoint s1 t1) then accu
else add_req accu (constr t1) s1 IdSet.empty in
let aux2 accu (t,s) =
List.fold_left (aux3 (pi s)) accu (Types.Product.get ~kind:k t) in
let aux accu (uid,t,xs,q1,q2) =
let q = selq (q1,q2) in
let xs = IdSet.cap xs q.fv in
let p = q.descr in
let t = pi t in
let vs = Approx.approx_var p t xs in
let xs = IdSet.diff xs vs in
let pr = side vs in
extra := (uid,pr)::!extra;
if (IdSet.is_empty xs) && (Types.subtype t (Types.descr q.accept))
then accu
else add_req accu p t xs in
let accu =
List.fold_left aux empty_reqs
(collect_all (collect_times k) reqs) in
let accu =
List.fold_left aux2 accu (collect_all collect_constr reqs) in
!extra,accu
let first_label reqs =
let min = ref LabelPool.dummy_max in
let f l = if l < !min then min := l in
let aux2 (t,_) = f (Types.Record.first_label t) in
let aux (_,_,_,l,_) = f l in
List.iter aux (collect_all collect_record reqs);
List.iter aux2 (collect_all collect_constr reqs);
!min
let rec find_binds q reqs binds fetch =
match (reqs,binds) with
......@@ -1862,15 +1925,17 @@ x=(1,2)
let mkopt p t xs = optimize t xs (mk p)
let demo ppf ((_,fv,_) as p) t =
let p = mkopt p t fv in
print ppf p;
let ts = collect_times `Normal [] p in
Format.fprintf ppf "@.First component:@.";
List.iter (fun (_,t,xs,q1,q2) ->
Format.fprintf ppf "%a / %a"
Print.print q1.descr
Types.Print.print (pi1 ~kind:`Normal t)
let p = mk p in
(* Format.fprintf ppf "%a@." print p; *)
let p = optimize t fv p in
Format.fprintf ppf "%a@." print p;
let ts = collect_record [] p in
Format.fprintf ppf "@.Fields:@.";
List.iter (fun (_,t,xs,l,q) ->
Format.fprintf ppf "(%a=%a) / %a@."
print_lab l
Print.print q.descr
Types.Print.print (Types.Record.project_opt t l)
) ts
end
......@@ -1891,6 +1956,7 @@ x=(1,2)
basic: (Types.t * result) list;
prod: actions_prod;
xml: actions_prod;
record: label;
}
and actions_prod =
| LeftRight of result dispatch dispatch
......@@ -2009,6 +2075,10 @@ x=(1,2)
Format.fprintf ppf " | %s(v2,v1) -> @.%a" pr print_prod1 d
| Impossible -> ()
let print_record ppf l =
Format.fprintf ppf "First label = %a@." print_lab l
let rec print_rescode ppf = function
| RFail -> Format.fprintf ppf "Fail"
| RCode i -> Format.fprintf ppf "(%i)" i
......@@ -2091,24 +2161,13 @@ x=(1,2)
let opt_all t0 =
List.map
(fun (p,t,xs) ->
if Types.subtype t t0 then (p,t,xs)
else let t = Types.cap t t0 in (Derivation.optimize t xs p, t, xs))
let get_results reqs =
List.map (fun (p,_,_) -> Derivation.get_result p) reqs
let collect_all f reqs =
List.fold_left (fun accu (p,_,_) -> f accu p) [] reqs
let mk_res t0 r reqs =
(* Format.fprintf Format.std_formatter "mk_res t=%a@." Types.Print.print t0;
List.iter (fun (p,_,_) ->
Format.fprintf Format.std_formatter "%a@."
Derivation.print p) reqs; *)
let res = get_results reqs in
let res = Derivation.get_results reqs in
let code = find_code res r.rescode in
(* let code = find_code_t0 t0 r in *)
if (code < 0) then (code,[||]) else
......@@ -2133,10 +2192,10 @@ x=(1,2)
let t0 = Types.cap r.assumpt Types.non_constructed in
if Types.is_empty t0 then []
else
let reqs = opt_all t0 r.reqs in
let qs = collect_all Derivation.collect_constr reqs in
let reqs = Derivation.opt_all t0 r.reqs in
let qs = Derivation.collect_all Derivation.collect_constr reqs in
let part = Types.cond_partition t0 qs in
List.map (fun t -> (t, mk_res t r (opt_all t reqs))) part
List.map (fun t -> (t, mk_res t r (Derivation.opt_all t reqs))) part
let prod_all k side pi sel selq reqs =
......@@ -2164,9 +2223,9 @@ x=(1,2)
else add_req accu p t xs in
let accu =
List.fold_left aux empty_reqs
(collect_all (Derivation.collect_times k) reqs) in
(Derivation.collect_all (Derivation.collect_times k) reqs) in
let accu =
List.fold_left aux2 accu (collect_all Derivation.collect_constr reqs) in
List.fold_left aux2 accu (Derivation.collect_all Derivation.collect_constr reqs) in
!extra,accu
let call_disp reqs f =
......@@ -2216,15 +2275,15 @@ x=(1,2)
| `RightLeft -> pi2 ~kind:k,pi1 ~kind:k,snd,snd,fst,fst,restr2 c,restr1 c,swap,swap in
let t0 = Types.cap r.assumpt (Types.Product.any_of k) in
if Types.is_empty t0 then Impossible else
let reqs = opt_all t0 r.reqs in
let reqs = Derivation.opt_all t0 r.reqs in
let extra1,reqs1 = prod_all k TargExpr.captures_left pi1 fst fst' reqs in
let second (t1,ar1,binds1) =
let t0 = restr1 t0 t1 in
let reqs = opt_all t0 reqs in
let reqs = Derivation.opt_all t0 reqs in
let extra2,reqs2 = prod_all k TargExpr.captures_right pi2 snd snd' reqs in
let final (t2,ar2,binds2) =
let t0 = restr2 t0 t2 in
let reqs = opt_all t0 reqs in
let reqs = Derivation.opt_all t0 reqs in
let aux = Derivation.set_times k swap swap' extra1 extra2 reqs1 reqs2 binds1 binds2 in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
mk_res t0 r reqs in
......@@ -2233,6 +2292,12 @@ x=(1,2)
match direction with
| `LeftRight -> LeftRight r
| `RightLeft -> RightLeft r
let record_disp r =
let t0 = Types.cap r.assumpt Types.Record.any in
let reqs = Derivation.opt_all t0 r.reqs in
Derivation.first_label reqs
let print_disp ppf r =
match r.actions with
| Some _ -> ()
......@@ -2240,11 +2305,18 @@ x=(1,2)
print ppf r;
let basic = basic_disp r
and prod = times_disp `RightLeft `Normal r
and xml = times_disp `LeftRight `XML r in
and xml = times_disp `LeftRight `XML r
and record = record_disp r in
print_basic_disp ppf basic;
print_prod "" ppf prod;
print_prod "XML" ppf xml;
r.actions <- Some (AKind { basic = basic; prod = prod; xml = xml })
print_record ppf record;
r.actions <- Some (AKind
{ basic = basic;
prod = prod;
xml = xml;
record = record;
})
let demo ppf t pl =
let (reqs,_) =
......@@ -2273,5 +2345,6 @@ let demo_compile = Compile2.Request.demo
(* Failure:
debug compile [ Int* Char* ] [ (x::Int|y::_)* ];;
debug approx { a = x; b = y } | { a = y; b = x } Any;;
*)
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