Commit 46e329bb authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-12-02 22:22:04 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-02 22:22:04+00:00
parent 47a1c26d
......@@ -44,8 +44,6 @@ types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx misc/state.cmx \
types/types.cmx types/patterns.cmi
types/record.cmo: types/boolean.cmi types/sortedList.cmi
types/record.cmx: types/boolean.cmx types/sortedList.cmx
types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo misc/state.cmi
......@@ -59,11 +57,11 @@ types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi misc/pool.cmi types/recursive.cmo \
types/intervals.cmi types/normal.cmi misc/pool.cmi types/recursive.cmo \
types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx misc/pool.cmx types/recursive.cmx \
types/intervals.cmx types/normal.cmx misc/pool.cmx types/recursive.cmx \
types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
misc/state.cmx types/types.cmi
runtime/eval.cmo: runtime/load_xml.cmi parser/location.cmi \
......@@ -112,8 +110,8 @@ types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sequence.cmi: types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi misc/pool.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
misc/pool.cmi types/sortedMap.cmi
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
......
......@@ -50,7 +50,7 @@ and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
| Record r -> run_disp_record r v [] r false actions.Patterns.Compile.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
actions.Patterns.Compile.basic
......@@ -92,26 +92,30 @@ and run_disp_prod2 v1 r1 v v2 x =
let (code2,r2) = run_dispatcher d2 v2 in
make_result_prod v1 r1 v2 r2 v b2.(code2)
and run_disp_record f v bindings fields = function
and run_disp_record f v bindings fields other = function
| None -> assert false
| Some record -> run_disp_record' f v bindings None fields record
| Some record -> run_disp_record' f v bindings None fields other record
and run_disp_record' f v bindings abs fields = function
| `Result r -> make_result_record f v bindings r
| `Absent -> run_disp_record f v bindings fields abs
and run_disp_record' f v bindings abs fields other = function
| `Result r ->
make_result_record f v bindings r
| `Result_other (r1,r2) ->
let other = other || fields <> [] in
make_result_record f v bindings (if other then r1 else r2)
| `Absent -> run_disp_record f v bindings fields other abs
| `Label (l, present, absent) ->
let rec aux = function
| (l1,_) :: rem when l1 < l -> aux rem
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field f v bindings abs rem l vl present
| _ -> run_disp_record f v bindings fields absent
run_disp_field f v bindings abs rem other l vl present
| _ -> run_disp_record f v bindings fields other absent
in
aux fields
aux other fields
and run_disp_field f v bindings abs fields l vl = function
and run_disp_field f v bindings abs fields other l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' f v bindings abs fields r
| `Ignore r -> run_disp_record' f v bindings abs fields other r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)
run_disp_record' f v ((l,rl)::bindings) abs fields other bl.(codel)
......@@ -699,6 +699,8 @@ module Normal : sig
type 'a nline = (result * 'a) list
type record =
[ `Success
| `SomeField
| `NoField
| `Fail
| `Dispatch of (nnf * record) list
| `Label of Types.label * (nnf * record) list * record ]
......@@ -742,6 +744,8 @@ struct
type 'a nline = (result * 'a) sl
type record =
[ `Success
| `SomeField
| `NoField
| `Fail
| `Dispatch of (nnf * record) list
| `Label of Types.label * (nnf * record) list * record ]
......@@ -755,6 +759,9 @@ struct
nrecord: record nline
}
let fus = SortedMap.union_disj
let slcup = SortedList.cup
(*
let nempty = { nfv = []; ncatchv = []; na = Types.empty;
nbasic = []; nprod = []; nxml = []; nrecord = [] }
......@@ -771,9 +778,6 @@ struct
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
......@@ -818,7 +822,7 @@ struct
na = acc;
nprod = SortedList.from_list prod
}
*)
let empty = { v = []; catchv = [];
......@@ -981,9 +985,11 @@ struct
let rec aux nr fields =
match (nr,fields) with
| (`Success, []) -> `Success
| (`Fail,_) -> `Fail
| (`Success, (l2,pl)::fields) ->
`Label (l2, [(pl,Types.any), aux nr fields], `Fail)
| (`SomeField, []) -> `SomeField
| (`NoField, []) -> `NoField
| (`Fail,_) | (`NoField,_::_) -> `Fail
| ((`Success|`SomeField), (l2,pl)::fields) ->
`Label (l2, [(pl,Types.any), aux `Success fields], `Fail)
| (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
`Label (l2, [(pl,Types.any), aux nr fields], `Fail)
| (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
......@@ -999,9 +1005,6 @@ struct
if x==ab then aux_ab else
aux x fields)) pr in
`Label (l1, pr, aux_ab)
(* TODO:!!!*)
| ((`NoField|`SomeField),_) -> aux `Success fields
in
let line accu ((res,fields),acc) =
......@@ -1043,6 +1046,7 @@ struct
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result
| `Result_other of result * result
| `Absent ]
and 'a dispatch =
......@@ -1380,20 +1384,20 @@ struct
let map_record f =
let rec aux = function
| [] -> []
| h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
| (res,catch,h)::t ->
(match f h with `Fail -> aux t | x -> (res,catch,x) :: (aux t)) in
Array.map aux
let label_found l =
map_record
(function
| (res, catch, `Label (l1, pr, _)) when l1 = l ->
(res, catch, `Dispatch pr)
| `Label (l1, pr, _) when l1 = l -> `Dispatch pr
| x -> x)
let label_not_found l =
map_record
(function
| (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
| `Label (l1, _, ab) when l1 = l -> ab
| x -> x)
(*
......@@ -1458,9 +1462,27 @@ struct
match collect_first_label pl with
| None ->
let aux_final (res, catch, x) =
assert (x = `Success);
List.map (conv_source_record catch) res in
`Result (return disp pl aux_final)
assert (x = `Success);
List.map (conv_source_record catch) res
in
let somefield =
if Types.Record.somefield_possible t then
let aux = function `Success | `SomeField -> `Success | _ -> `Fail in
Some (return disp (map_record aux pl) aux_final)
else None
in
let nofield =
if Types.Record.nofield_possible t then
let aux = function `Success | `NoField -> `Success | _ -> `Fail in
Some (return disp (map_record aux pl) aux_final)
else None
in
(match (somefield,nofield) with
| Some r1, Some r2 ->
if r1 = r2 then `Result r1 else `Result_other(r1,r2)
| Some r1, None -> `Result r1
| None, Some r2 -> `Result r2
| _ -> assert false)
| Some l ->
let (plabs,absent) =
let pl = label_not_found l pl in
......@@ -1470,16 +1492,22 @@ struct
let present =
let pl = label_found l pl in
let t = Types.Record.restrict_label_present t l in
get_tests pl
(function
| (res,catch, `Dispatch d) ->
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t plabs)
(fun x -> combine x)
if Types.Record.is_empty t then None else
Some (
get_tests pl
(function
| (res,catch, `Dispatch d) ->
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t plabs)
(fun x -> combine x)
)
in
combine_record l present absent
(match (present,absent) with
| (Some present, absent) -> combine_record l present absent
| (None, Some absent) -> absent
| _ -> assert false)
and dispatch_record_field l disp t plabs tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, ncatchv, (res, catch, rem)) =
......@@ -1609,7 +1637,9 @@ struct
Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| `Result r -> print_ret ppf r
| `Result r -> Format.fprintf ppf "%a" print_ret r
| `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"
print_ret r1 print_ret r2
| `Absent -> Format.fprintf ppf "Jump to Absent"
| `Label (l, present, absent) ->
let l = Types.LabelPool.value l in
......@@ -1621,7 +1651,9 @@ struct
print_record r
| None -> ()
and print_present l ppf = function
| `None -> assert false
| `None ->
Format.fprintf ppf "(cannot happen)"
(* assert false *)
| `TailCall d ->
queue d;
Format.fprintf ppf "disp_%i@\n" d.id
......
......@@ -59,7 +59,8 @@ module Compile: sig
}
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result
| `Result of result
| `Result_other of result * result
| `Absent ]
and 'a dispatch =
......
......@@ -50,6 +50,11 @@ let add f x y m =
let change x f =
add (fun _ -> f) x
let rec change_exists x1 f = function
| [] -> raise Not_found
| (x,y)::q when x = x1 -> (x,f y)::q
| h::q -> h::(change_exists x1 f q)
let rec diff l1 l2 =
match (l1,l2) with
| (((x1,y1) as t1)::q1, x2::q2) ->
......
......@@ -11,6 +11,8 @@ val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t
val change: 'a -> ('b -> 'b) -> 'b -> ('a,'b) t -> ('a,'b) t
val change_exists: 'a -> ('b -> 'b) -> ('a,'b) t -> ('a,'b) t
val diff: ('a,'b) t -> 'a SortedList.t -> ('a,'b) t
val iter: ('a -> 'b -> unit) -> ('a,'b) t -> unit
......
......@@ -194,6 +194,8 @@ let any = descr any_node
let neg x = diff any x
let any_node = cons any
(*
let get_record r =
let add = SortedMap.add (fun (o1,t1) (o2,t2) -> (o1&&o2, cap t1 t2)) in
......@@ -981,6 +983,12 @@ struct
| (true,[]) -> Boolean.full
| (o,l) -> Boolean.atom (o,l)
let somefield_possible t =
not (R.empty (R.diff t (Boolean.atom (false,[]))))
let nofield_possible t =
not (R.empty (R.cap t (Boolean.atom (false,[]))))
let restrict_label_absent t l =
Boolean.compute_bool
(fun (o,r) as x ->
......@@ -1023,11 +1031,16 @@ struct
TR.boolean x
let restrict_label_present t l =
t
(*
let r = label_present t l in
List.fold_left (fun accu (_,t) -> Boolean.cup accu t) Boolean.empty r
*)
Boolean.compute_bool
(fun (o,r) as x ->
try
Boolean.atom (o, SortedMap.change_exists l (fun (_,lt) -> (false,lt)) r)
with Not_found ->
if o then Boolean.atom
(true, SortedMap.union_disj [l, (false,any_node)] r)
else Boolean.empty
)
t
let project_field t l =
let r = label_present t l in
......
......@@ -101,6 +101,8 @@ module Record : sig
val restrict_label_absent: t -> label -> t
val restrict_label_present: t -> label -> t
val label_present: t -> label -> (descr * t) list
val somefield_possible: t -> bool
val nofield_possible: t -> bool
val any : descr
val project_field: t -> label -> descr
val project : descr -> label -> descr
......
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