Skip to content

GitLab

Commit 75975fa4 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-25 19:28:34 by afrisch] Records again 

Original author: afrisch
Date: 2004-12-25 19:28:35+00:00
parent 2c52fed9
Hide whitespace changes
Inline Side-by-side
types/patterns.ml
View file @ 75975fa4
......@@ -1568,6 +1568,8 @@ end
module Compile2 = struct
let any_or_abs = Types.Record.any_or_absent
module PatList = SortedList.Make(struct include Custom.Dummy include Pat end)
module TypesFv = Custom.Pair(Types)(IdSet)
module Req = PatList.MakeMap(TypesFv)
......@@ -1659,6 +1661,20 @@ x=(1,2)
| SrcFetchRight of int
| SrcLocal of int
(*
let rec equal_src s1 s2 = (s1 == s2) || match (s1,s2) with
| SrcCst c1, SrcCst c2 -> Types.Const.equal c1 c2
| SrcPair (s1,ss1), SrcPair (s2,ss2) ->
equal_src s1 s2 && equal_src ss1 ss2
| SrcFetchLeft i, SrcFetchLeft j
| SrcFetchRight i, SrcFetchRight j
| SrcLocal i, SrcLocal j when i == j -> true
| _ -> false
let equal = IdMap.equal equal_src
*)
type push = PushConst of Types.const | PushField | PushCapture
let capture x = IdMap.singleton x SrcCapture
......@@ -1704,6 +1720,26 @@ x=(1,2)
| TTimes of Types.pair_kind * int * descr * Types.t * fv * node * node
| TRecord of int * descr * Types.t * fv * label * node
(*
let rec same p1 p2 = (p1 == p2) || match (p1,p2) with
| TConstr (t1,s1), TConstr (t2,s2) ->
Types.equiv s1 s2 &&
Types.equiv (Types.cap t1 s1) (Types.cap t2 s2)
| TCapt (pr1,p1), TCapt (pr2,p2) ->
TargExpr.equal pr1 pr2 && same p1 p2
| TAlt (p1,_,a1,b1), TAlt (p2,_,a2,b2) ->
(p1 == p2) && (same a1 a2) && (same b1 b2)
| TConj (_,_,a1,b1), TConj (_,_,a2,b2) ->
same a1 a2 && same b1 b2
| TTimes (k1,uid1,p1,t1,xs1,a1,b1),
TTimes (k2,uid2,p2,t2,xs2,a2,b2) ->
assert false
| TRecord (uid1,_,t1,_,_,_),
TRecord (uid2,_,t2,_,_,_) ->
(uid1 == uid2) && (Types.equiv t1 t2)
| _ -> false
*)
(* TODO: allocate the stack locations by sorting the ids
(to allow ({ l = (x,y) } | (x:=1)&(y:=2))) *)
let push_csts pushes locals =
......@@ -1776,13 +1812,17 @@ x=(1,2)
Print.print q1.descr
Print.print q2.descr
exception NotAResult
let get_result = function
| TSucceed -> Some TargExpr.empty
| TCapt (r,TSucceed) -> Some r
| TFail -> None
| r ->
| r -> raise NotAResult
(*
Format.fprintf Format.std_formatter "ERR: %a@." print r;
assert false
*)
let print_result ppf = function
| None -> Format.fprintf ppf "Fail"
......@@ -1791,17 +1831,17 @@ x=(1,2)
let uid = ref 0
let rec mk ((a,fv,d) as p) = match d with
| Constr t -> TConstr (t, Types.any)
| Constr t -> TConstr (t, any_or_abs)
| Cup ((a1,_,_) as p1,p2) -> TAlt (p, a1,mk p1, mk p2)
| Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
| Capture x -> success (TargExpr.capture x)
| Constant (x,c) -> success (TargExpr.cst x c)
| Times (q1,q2) ->
TTimes (`Normal,(incr uid; !uid), p,Types.any,fv,q1,q2)
TTimes (`Normal,(incr uid; !uid), p, any_or_abs,fv,q1,q2)
| Xml (q1,q2) ->
TTimes (`XML,(incr uid; !uid), p,Types.any,fv,q1,q2)
TTimes (`XML,(incr uid; !uid), p,any_or_abs,fv,q1,q2)
| Record (l,q) ->
TRecord ((incr uid; !uid),p, Types.any,fv,l,q)
TRecord ((incr uid; !uid),p, any_or_abs,fv,l,q)
| Dummy -> assert false
let constrain a t =
......@@ -1922,6 +1962,9 @@ x=(1,2)
let xs = IdSet.cap xs q.fv and p = q.descr and t = pi t in
let pr,xs = approx_var p t xs side in
let pr',xs = approx_cst p t xs TargExpr.constants in
let pr = TargExpr.merge pr pr' in
extra := (uid,pr)::!extra;
if not ((IdSet.is_empty xs)
&& (Types.subtype t (Types.descr q.accept))) then
......@@ -2016,10 +2059,11 @@ x=(1,2)
| RFail
| RCode of int
| RSwitch of rescode * rescode
| RIgnore of rescode
type result = int * TargExpr.source array
type actions =
| AIgnore of result
| AResult of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
......@@ -2028,9 +2072,10 @@ x=(1,2)
record: actions_record;
}
and actions_record =
| RecordLabel of label * dispatcher * record_tr array
| RecordLabelSkip of label * record_tr
| RecordNolabel of result
| RecordLabel of label * dispatcher * record_tr array * record_tr
| RecordLabelSkip of label * record_tr * record_tr
| RecordResult of result
| RecordMore of result * result (* nomore, more *)
| RecordImpossible
and record_tr = (TargExpr.push list * actions_record)
and actions_prod =
......@@ -2078,7 +2123,7 @@ x=(1,2)
Format.fprintf ppf "%a. t=%a. xs=%a@."
Derivation.print p
Types.Print.print t
Print.print_xs xs) r.reqs
Print.print_xs xs) r.reqs;
*)
()
......@@ -2163,21 +2208,29 @@ x=(1,2)
) l
let rec print_field ppf = function
| RecordImpossible -> ()
| RecordLabel (l,d,cts) ->
let rec print_record_tr ppf (pushes,x) =
Format.fprintf ppf "%a%a" print_pushes pushes print_field x
and print_field ppf = function
| RecordImpossible ->
Format.fprintf ppf "#"
| RecordLabel (l,d,cts,abs) ->
to_print d;
Format.fprintf ppf "(label:%a,disp_%i" print_lab l d.id;
Array.iteri (fun i (pushes,x) ->
Format.fprintf ppf ";%i->%a%a" i
print_pushes pushes print_field x) cts;
Format.fprintf ppf ")"
| RecordLabelSkip (l,(pushes,cts)) ->
Format.fprintf ppf "(label:%a;%a%a)" print_lab l
print_pushes pushes
print_field cts
| RecordNolabel res ->
Format.fprintf ppf "[%a]" print_result res
Array.iteri (fun i x ->
Format.fprintf ppf ";%i->%a" i
print_record_tr x) cts;
Format.fprintf ppf ";abs:%a)" print_record_tr abs
| RecordLabelSkip (l,x,abs) ->
Format.fprintf ppf "(label:%a;%a;abs:%a)" print_lab l
print_record_tr x print_record_tr abs
| RecordMore (nomore,more) ->
Format.fprintf ppf "[nomore:%a;more:%a]"
print_result nomore
print_result more
| RecordResult res ->
Format.fprintf ppf "[%a]"
print_result res
let print_record ppf r =
Format.fprintf ppf "Record:%a@." print_field r
......@@ -2187,10 +2240,13 @@ x=(1,2)
| RCode i -> Format.fprintf ppf "(%i)" i
| RSwitch (a,b) ->
Format.fprintf ppf "S(%a,%a)" print_rescode a print_rescode b
| RIgnore a ->
Format.fprintf ppf "I(%a)" print_rescode a
let rec find_code bl rc = match (bl,rc) with
| Some _::bl,RSwitch (rc,_) | None::bl,RSwitch (_,rc) -> find_code bl rc
| ([], RCode i) -> i
| _::bl,RIgnore rc -> find_code bl rc
| [], RCode i -> i
| _ -> (-1) (* assert false *)
(*
......@@ -2203,6 +2259,7 @@ x=(1,2)
find_code bl rc
*)
(*
let find_code_t0 t0 r =
let rec aux i =
if i = Array.length r.outputs then (-1)
......@@ -2211,6 +2268,7 @@ x=(1,2)
if Types.subtype t0 t then i else aux (succ i)
in
aux 0
*)
let alloc pos fv =
let i = ref (pos - 1) in
......@@ -2227,19 +2285,22 @@ x=(1,2)
else match l with
| [] -> incr nb; codes := (t0,ar,List.rev binds) :: !codes; RCode !nb
| ((a,_,_),(t,xs)) :: rem ->
let (alc,ar') = alloc ar xs in
RSwitch
(aux (Types.diff t0 (Types.diff t a))
ar' (Some alc::binds) rem,
aux (Types.diff t0 (Types.cap t a))
ar (None::binds) rem)
if Types.disjoint t t0
then RIgnore (aux t0 ar (None::binds) rem)
else
let (alc,ar') = alloc ar xs in
RSwitch
(aux (Types.diff t0 (Types.diff t a))
ar' (Some alc::binds) rem,
aux (Types.diff t0 (Types.cap t a))
ar (None::binds) rem)
in
let reqs = PatList.Map.get reqs in
let t0 =
List.fold_left
(fun accu (_,(t,_)) -> Types.cup accu t) Types.empty
reqs in
(* let t0 = Types.any in *)
reqs in
(* let t0 = any_or_abs in *)
let rc = aux t0 0 [] reqs in
let reqs =
List.map
......@@ -2265,14 +2326,13 @@ x=(1,2)
let mk_res t0 r reqs =
let mk_res 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 = 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
let (_,ar,fill) = r.outputs.(code) in
let o = Array.make ar (TargExpr.SrcFetchLeft (-1)) in
......@@ -2292,18 +2352,18 @@ x=(1,2)
(code,o)
let basic_disp r =
let t0 = Types.cap r.assumpt Types.non_constructed in
let t0 = Types.cap r.assumpt Types.non_constructed_or_absent in
if Types.is_empty t0 then []
else
let reqs = Derivation.opt_all t0 r.reqs in
let qs = ref [] in let aux x = qs := x::!qs in
Derivation.iter_all Derivation.iter_constr aux reqs;
let part = Types.cond_partition t0 !qs in
List.map (fun t -> (t, mk_res t r (Derivation.opt_all t reqs))) part
List.map (fun t -> (t, mk_res r (Derivation.opt_all t reqs))) part
let call_disp reqs f =
if PatList.Map.is_empty reqs then Ignore (f (Types.any,0,[]))
if PatList.Map.is_empty reqs then Ignore (f (any_or_abs,0,[]))
else let d = mk reqs in Dispatch (d, Array.map f d.outputs)
let check_tail_call2 d brs =
......@@ -2368,24 +2428,58 @@ x=(1,2)
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
mk_res r reqs in
opt_tail_call2 (call_disp reqs2 final) in
let r = opt_tail_call1 (call_disp reqs1 second) in
match direction with
| `LeftRight -> LeftRight r
| `RightLeft -> RightLeft r
(*
let same_all reqs1 reqs2 =
let aux (p1,t1,xs1) (p2,t2,xs2) = Derivation.same p1 p2 in
List.for_all2 aux reqs1 reqs2
*)
let record_disp r =
let t0 = Types.cap r.assumpt Types.Record.any in
if Types.is_empty t0 then RecordImpossible else
let reqs = Derivation.opt_all t0 r.reqs in
let labs = Derivation.all_labels reqs in
let all_labs = Derivation.all_labels reqs in
(* TODO: memoize the field function *)
let rec field t0 reqs locals = function
let rec field t0 reqs locals labs =
if Types.is_empty t0 then RecordImpossible
else
try RecordResult (mk_res r reqs)
with Derivation.NotAResult -> field' t0 reqs locals labs
and field' t0 reqs locals = function
| [] ->
(* TODO: distinguish between More / No more fields *)
RecordNolabel (mk_res t0 r reqs)
let fs = List.map
(fun x -> x,Types.Record.any_or_absent_node) all_labs in
let t = Types.record' (false, LabelMap.from_list_disj fs) in
let nomore = mk_res r (Derivation.opt_all (Types.cap t0 t) reqs)
and more = mk_res r (Derivation.opt_all (Types.diff t0 t) reqs) in
RecordMore (nomore,more)
| l::labs ->
let cont t0 locals reqs =
let locals = ref locals in
let pushes = ref [] in
let aux = Derivation.push_csts pushes locals in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
(List.rev !pushes, field t0 reqs !locals labs) in
(* absent *)
let absent =
let t0 = Types.cap t0
(Types.record l Types.Record.absent_node) in
let reqs = Derivation.opt_all t0 reqs in
cont t0 locals reqs in
let reqs0 = reqs in
(* present *)
let t0 = Types.cap t0 (Types.record l Types.any_node) in
let reqs = Derivation.opt_all t0 reqs in
let extra1,reqs1 = Derivation.record_all l reqs in
let contin (t1,ar1,binds1) =
let t0 = Types.cap t0 (Types.record l (Types.cons t1)) in
......@@ -2393,42 +2487,58 @@ x=(1,2)
let aux =
Derivation.set_field l locals extra1 reqs1 binds1 in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
let locals = ref (locals + ar1) in
let pushes = ref [] in
let aux = Derivation.push_csts pushes locals in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
(List.rev !pushes, field t0 reqs !locals labs)
cont t0 (locals + ar1) reqs
in
if PatList.Map.is_empty reqs1
then
match contin (Types.any,0,[]) with
| [],c -> c
| x -> RecordLabelSkip (l,x)
(* Check if present or absent does not matter *)
(* other possible algo: compare a posteriori the two continuations *)
let nomat = false in
(*
match absent with
| (_,RecordImpossible) -> true
| ([],_) ->
PatList.Map.is_empty
(snd (Derivation.record_all l reqs0))
| _ -> false in
*)
match contin (any_or_abs,0,[]) with
| ([],c) when nomat -> c
| x -> RecordLabelSkip (l,x,absent)
else
let d = mk reqs1 in
RecordLabel (l, d, Array.map contin d.outputs)
RecordLabel (l, d, Array.map contin d.outputs, absent)
in
field t0 reqs 0 labs
field t0 reqs 0 all_labs
let compute_action r =
try AResult (mk_res r r.reqs)
with Derivation.NotAResult ->
AKind
{ basic = basic_disp r ;
prod = times_disp `RightLeft `Normal r;
xml = times_disp `LeftRight `XML r;
record = record_disp r
}
let print_action ppf = function
| AKind a ->
print_basic_disp ppf a.basic;
print_prod "" ppf a.prod;
print_prod "XML" ppf a.xml;
print_record ppf a.record
| AResult res ->
Format.fprintf ppf "%a@." print_result res
let print_disp ppf r =
match r.actions with
| Some _ -> ()
| None ->
print ppf r;
let basic = basic_disp r
and prod = times_disp `RightLeft `Normal r
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;
print_record ppf record;
r.actions <- Some (AKind
{ basic = basic;
prod = prod;
xml = xml;
record = record;
})
let act = compute_action r in
print_action ppf act;
r.actions <- Some act
let demo ppf t pl =
let (reqs,_) =
......
types/types.ml
View file @ 75975fa4
......@@ -493,6 +493,8 @@ let non_constructed =
hash = 0;
times = empty.times; xml = empty.xml; record = empty.record }
let non_constructed_or_absent =
{ non_constructed with hash = 0; absent = true }
let interval i = { empty with hash = 0; ints = i }
let times x y = { empty with hash = 0; times = BoolPair.atom (x,y) }
......@@ -590,6 +592,7 @@ and const_node c = cons (constant c)
let neg x = diff any x
let any_node = cons any
let empty_node = cons empty
module LabelS = Set.Make(LabelPool)
......@@ -950,6 +953,8 @@ let subtype d1 d2 =
let disjoint d1 d2 =
is_empty (cap d1 d2)
let equiv d1 d2 = (subtype d1 d2) && (subtype d2 d1)
module Product =
struct
type t = (descr * descr) list
......@@ -1104,11 +1109,12 @@ module Record =
struct
let has_record d = not (is_empty { empty with hash= 0; record = d.record })
let or_absent d = { d with hash = 0; absent = true }
let absent = or_absent empty
let any_or_absent = or_absent any
let any_or_absent_node = cons any_or_absent
let has_absent d = d.absent
let only_absent = {empty with hash = 0; absent = true}
let only_absent_node = cons only_absent
let absent_node = cons absent
module T = struct
type t = descr
......@@ -1148,7 +1154,7 @@ struct
if LabelMap.is_empty r then Any else
Pair (any_or_absent, { empty with hash=0; record = BoolRec.atom (o,r) })
else
Pair (only_absent,
Pair (absent,
{ empty with hash = 0; record = BoolRec.atom (o,r) })
in
List.fold_left
......@@ -1190,11 +1196,11 @@ struct
let condition d l t =
TR.pi2_restricted t (split d l)
(* TODO: eliminate this cap ... (reord l only_absent_node) when
(* TODO: eliminate this cap ... (record l absent_node) when
not necessary. eg. {| ..... |} \ l *)
let remove_field d l =
cap (TR.pi2 (split d l)) (record l only_absent_node)
cap (TR.pi2 (split d l)) (record l absent_node)
let all_labels d =
let res = ref LabelSet.empty in
......
types/types.mli
View file @ 75975fa4
......@@ -69,8 +69,10 @@ val empty : t
val any : t
val any_node : Node.t
val empty_node : Node.t
val non_constructed : t
val non_constructed_or_absent : t
(** Constructors **)
......@@ -160,8 +162,11 @@ end
module Record : sig
val any : t
val absent : t
val absent_node : Node.t
val or_absent: t -> t
val any_or_absent: t
val any_or_absent_node : Node.t
val has_absent: t -> bool
val has_record: t -> bool
......@@ -253,6 +258,7 @@ val is_empty : t -> bool
val non_empty: t -> bool
val subtype : t -> t -> bool
val disjoint : t -> t -> bool
val equiv : t -> t -> bool
(** Tools for compilation of PM **)
......
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