Commit 2e84aee9 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-03-10 22:35:20 by cvscast] De nouveau rapides, les records

Original author: cvscast
Date: 2003-03-10 22:35:21+00:00
parent 8cc2fba7
......@@ -39,12 +39,9 @@ let rec print_exn ppf = function
print_value v
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection: the label %s@\n"
(Types.LabelPool.value l);
(LabelPool.value l);
Format.fprintf ppf "applied to an expression of type %a@\n"
print_norm t
| Typer.MultipleLabel l ->
Format.fprintf ppf "Multiple occurences for the record label %s@\n"
(Types.LabelPool.value l);
| Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
print_norm t
......
......@@ -35,13 +35,13 @@ and pexpr' =
| Cst of Types.const
| Pair of pexpr * pexpr
| Xml of pexpr * pexpr
| RecordLitt of (Types.label * pexpr) list
| RecordLitt of pexpr label_map
(* Data destructors *)
| Op of string * pexpr list
| Match of pexpr * branches
| Map of pexpr * branches
| Dot of (pexpr* Types.label)
| Dot of (pexpr* label)
(* Exceptions *)
| Try of pexpr * branches
......@@ -68,7 +68,7 @@ and ppat' =
| XmlT of ppat * ppat
| Arrow of ppat * ppat
| Optional of ppat
| Record of bool * (Types.label * ppat) list
| Record of bool * ppat label_map
| Capture of id
| Constant of id * Types.const
| Regexp of regexp * ppat
......
......@@ -28,6 +28,8 @@ let rec tuple loc = function
let tuple_queue =
List.fold_right (fun x q -> mk x.loc (Pair (x, q)))
let char = mk noloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
......@@ -44,6 +46,9 @@ let seq_of_string pos s =
exception Error of string
let error loc s = raise (Location (loc, Error s))
let make_record loc r =
LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
let parse_char loc s =
(* TODO: Unicode *)
if String.length s <> 1 then
......@@ -126,7 +131,7 @@ EXTEND
]
|
[ e = expr; "."; l = [LIDENT | UIDENT] ->
mk loc (Dot (e,Types.LabelPool.mk l))
mk loc (Dot (e,LabelPool.mk l))
]
|
......@@ -163,7 +168,7 @@ EXTEND
| "<"; e = expr LEVEL "no_appl" -> e ];
a = expr_attrib_spec; ">"; c = expr ->
mk loc (Xml (t, mk loc (Pair (a,c))))
| "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
| "{"; r = [ expr_record_spec | -> mk loc (RecordLitt LabelMap.empty) ]; "}" -> r
| s = STRING2 ->
tuple loc (char_list loc s @ [cst_nil])
| a = LIDENT -> mk loc (Var (ident a))
......@@ -328,10 +333,9 @@ EXTEND
o = [ "?" -> true | -> false];
x = pat ->
let x = if o then mk loc (Optional x) else x in
(Types.LabelPool.mk l, x)
(LabelPool.mk l, x)
] SEP ";" ->
(* TODO: check here uniqueness *)
List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r
make_record loc r
] ];
char:
......@@ -356,15 +360,15 @@ EXTEND
expr_record_spec:
[ [ r = LIST1
[ l = [LIDENT | UIDENT]; "="; x = expr ->
(Types.LabelPool.mk l,x) ]
(LabelPool.mk l,x) ]
SEP ";" ->
mk loc (RecordLitt r)
mk loc (RecordLitt (make_record loc r))
] ];
expr_attrib_spec:
[ [ r = expr_record_spec -> r ]
| [ e = expr LEVEL "no_appl" -> e
| -> mk loc (RecordLitt [])
| -> mk loc (RecordLitt (LabelMap.empty))
]
];
END
......
......@@ -43,10 +43,10 @@ let rec eval env e0 =
self
(* Optimizations:
- for the non-recursive case, use eval_branches
- for the recursive case, could cheat bt pathing self afterwards:
- for the recursive case, could cheat by patching self afterwards:
(Obj.magic self).(1) <- ....
*)
| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
| Typed.Cst c -> const c
......@@ -112,7 +112,7 @@ and eval_concat l1 l2 = match l1 with
| q -> l2
and eval_dot l = function
| Record r -> List.assoc l r
| Record r -> LabelMap.assoc l r
| _ -> assert false
and eval_add x y = match (x,y) with
......
......@@ -6,6 +6,7 @@ open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Value
open Ident
let is_ws s =
let rec check i =
......@@ -20,8 +21,8 @@ let string s q =
String (0,String.length s,s,q)
let attrib att =
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
SortedMap.from_list (fun _ _ -> assert false) att
let att = List.map (fun (l,v) -> LabelPool.mk l, string v nil) att in
LabelMap.from_list (fun _ _ -> assert false) att
let elem tag att child =
Xml (Atom (Atoms.mk tag), Pair (Record (attrib att), child))
......
......@@ -3,6 +3,7 @@
open Pxp_aux
open Pxp_types
open Value
open Ident
let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.mk "Invalid_argument"),
......@@ -43,9 +44,10 @@ let string_of_xml v=
let rec print_elt = function
| Xml (Atom tag, Pair (Record attrs, content)) ->
let tag = Atoms.value tag in
let attrs = List.map (fun (n,v) ->
if not (is_str v) then raise exn_print_xml;
(Types.LabelPool.value n,get_string v)) attrs in
let attrs = LabelMap.mapi_to_list
(fun n v ->
if not (is_str v) then raise exn_print_xml;
(LabelPool.value n,get_string v)) attrs in
(match content with
| Atom a when a = Sequence.nil_atom -> empty_element tag attrs
| _ ->
......
(* Running dispatchers *)
open Value
open Ident
open Patterns.Compile
let make_result_prod v1 r1 v2 r2 v (code,r) =
......@@ -71,7 +72,7 @@ and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
| Record r -> run_disp_record false v r actions.record
| Record r -> run_disp_record false v (LabelMap.get r) actions.record
| String (i,j,s,q) -> run_disp_string i j s q actions
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
......
open Ident
type t =
| Pair of t * t
| Xml of t * t
| Record of (Types.label,t) SortedMap.t
| Record of t label_map
| Atom of Atoms.v
| Integer of Intervals.v
| Char of Chars.v
......@@ -54,7 +56,7 @@ let rec print ppf v =
else match v with
| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
| Xml (x,y) -> print_xml ppf (x,y)
| Record l -> Format.fprintf ppf "{%a }" print_record l
| Record l -> Format.fprintf ppf "{%a }" print_record (LabelMap.get l)
| Atom a -> Atoms.print_v ppf a
| Integer i -> Intervals.print_v ppf i
| Char c -> Chars.print_v ppf c
......@@ -94,7 +96,7 @@ and print_xml ppf = function
| (Atom tag, Pair (Record attr,content)) ->
Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
(Atoms.value tag)
print_record attr
print_record (LabelMap.get attr)
print_seq content
| _ -> assert false
......@@ -104,7 +106,7 @@ and print_record ppf = function
| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
and print_field ppf (l,v) =
Format.fprintf ppf "%s=%a" (Types.LabelPool.value l) print v
Format.fprintf ppf "%s=%a" (LabelPool.value l) print v
let normalize = function
......
open Ident
type t =
(* Canonical representation *)
| Pair of t * t
| Xml of t * t
| Record of (Types.label,t) SortedMap.t
| Record of t label_map
| Atom of Atoms.v
| Integer of Intervals.v
| Char of Chars.v
......
......@@ -6,3 +6,11 @@ type 'a id_map = (unit,'a) IdMap.map
type fv = unit IdSet.t
let ident = Id.mk
module LabelPool = Pool.Make(SortedList.String)
module LabelSet = SortedList.Make(SortedList.Lift(LabelPool))
module LabelMap = LabelSet.Map
type label = LabelPool.t
type 'a label_map = (unit,'a) LabelMap.map
......@@ -10,6 +10,8 @@ sig
val is_empty: t -> bool
end
type 'a bool = ('a list * 'a list) list
module Make(X1 : S)(X2 : S) =
struct
type t = (X1.t * X2.t) list
......
......@@ -10,6 +10,7 @@ sig
val is_empty: t -> bool
end
type 'a bool = ('a list * 'a list) list
module Make(X1 : S)(X2 : S) :
sig
type t = (X1.t * X2.t) list
......@@ -20,10 +21,10 @@ sig
(t1,t2) => t1 <> 0, t2 <> 0
*)
val boolean_normal: (X1.t * X2.t) Boolean.t -> t
val boolean_normal: (X1.t * X2.t) bool -> t
(* return a normalized form *)
val boolean: (X1.t * X2.t) Boolean.t -> t
val boolean: (X1.t * X2.t) bool -> t
val pi1: t -> X1.t
val pi2_restricted: X1.t -> t -> X2.t
......
......@@ -9,7 +9,7 @@ type d =
| Cap of descr * descr
| Times of node * node
| Xml of node * node
| Record of Types.label * node
| Record of label * node
| Capture of id
| Constant of id * Types.const
and node = {
......@@ -39,7 +39,7 @@ let rec print ppf (a,_,d) =
Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
to_print := n1 :: n2 :: !to_print
| Record (l,n) ->
Format.fprintf ppf "{ %s = P%i }" (Types.LabelPool.value l) n.id;
Format.fprintf ppf "{ %s = P%i }" (LabelPool.value l) n.id;
to_print := n :: !to_print
| Capture x ->
Format.fprintf ppf "%s" (Id.value x)
......@@ -188,7 +188,7 @@ module Normal : sig
type 'a nline = (result * 'a) list
type record =
| RecNolabel of result option * result option
| RecLabel of Types.label * (nnf * nnf) nline
| RecLabel of label * (nnf * nnf) nline
type t = {
nfv : fv;
ncatchv: fv;
......@@ -200,8 +200,8 @@ module Normal : sig
}
val any_basic: Types.descr
val first_label: descr -> Types.label
val normal: Types.label option -> Types.descr -> node list -> t
val first_label: descr -> label
val normal: label option -> Types.descr -> node list -> t
end =
struct
let any_basic =
......@@ -224,7 +224,7 @@ struct
type 'a nline = (result * 'a) sl
type record =
| RecNolabel of result option * result option
| RecLabel of Types.label * (nnf * nnf) nline
| RecLabel of label * (nnf * nnf) nline
type t = {
nfv : fv;
ncatchv: fv;
......@@ -342,8 +342,8 @@ struct
| None -> assert false
| Some label ->
(* Printf.eprintf "[ l = %s; label = %s ]\n"
(Types.LabelPool.value l)
(Types.LabelPool.value label); *)
(LabelPool.value l)
(LabelPool.value label); *)
assert (label <= l);
if l == label then
let src = IdMap.constant SLeft p.fv in
......@@ -434,14 +434,14 @@ struct
let rec first_label (acc,fv,d) =
if Types.is_empty acc
then Types.LabelPool.dummy_max
then LabelPool.dummy_max
else match d with
| Constr t -> Types.Record.first_label t
| Cap (p,q) -> min (first_label p) (first_label q)
| Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
(* should "first_label_type acc1" ? *)
| Record (l,p) -> l
| _ -> Types.LabelPool.dummy_max
| _ -> LabelPool.dummy_max
let remove_catchv n =
......@@ -489,7 +489,7 @@ struct
record: record option;
}
and record =
| RecLabel of Types.label * result dispatch dispatch
| RecLabel of label * result dispatch dispatch
| RecNolabel of result option * result option
and 'a dispatch =
......@@ -516,7 +516,7 @@ struct
id : int;
t : Types.descr;
pl : Normal.t array;
label : Types.label option;
label : label option;
interface : interface;
codes : return_code array;
mutable actions : actions option;
......@@ -739,8 +739,8 @@ struct
(fun l p -> min l (Normal.first_label (descr p)))
(min l (Types.Record.first_label ty))
pl
) Types.LabelPool.dummy_max !accu in
let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in
) LabelPool.dummy_max !accu in
let lab = if lab= LabelPool.dummy_max then None else Some lab in
let accu =
List.map (fun (ty,pl,i,info) ->
......@@ -965,7 +965,7 @@ struct
Format.fprintf ppf "SomeField:%a;NoField:%a"
print_ret_opt r1 print_ret_opt r2
| RecLabel (l, d) ->
let l = Types.LabelPool.value l in
let l = LabelPool.value l in
Format.fprintf ppf "check label %s:@\n" l;
Format.fprintf ppf "Present => @[%a@]@\n" (print_prod "record") d
in
......@@ -1024,7 +1024,7 @@ struct
List.fold_left
(fun l p -> min l (Normal.first_label (descr p)))
(Types.Record.first_label t) pl in
let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in
let lab = if lab= LabelPool.dummy_max then None else Some lab in
let pl = Array.of_list
(List.map (fun p -> Normal.normal lab Types.Record.any_or_absent [p]) pl) in
......
......@@ -15,7 +15,7 @@ val cap : descr -> descr -> descr
val times : node -> node -> descr
val xml : node -> node -> descr
val record : Types.label -> node -> descr
val record : label -> node -> descr
val capture : id -> descr
val constant: id -> Types.const -> descr
......@@ -56,7 +56,7 @@ module Compile: sig
record: record option;
}
and record =
| RecLabel of Types.label * result dispatch dispatch
| RecLabel of label * result dispatch dispatch
| RecNolabel of result option * result option
and 'a dispatch =
| Dispatch of dispatcher * 'a array
......
......@@ -60,8 +60,10 @@ sig
type ('a,'b) map
external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
val empty: ('a,'b) map
val iter: ('b -> unit) -> ('a,'b) map -> unit
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
......@@ -70,6 +72,7 @@ sig
val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map
val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map
val constant: 'b -> 'a t -> ('a,'b) map
val num: int -> 'a t -> ('a,int) map
val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
......@@ -219,6 +222,23 @@ module Map = struct
let is_empty l = l = []
let singleton x y = [ (x,y) ]
let rec iter f = function
| (_,y)::l -> f y; iter f l
| [] -> ()
let rec assoc_remove_aux v r = function
| ((x,y) as a)::l ->
let c = X.compare x v in
if c = 0 then (r := y; l)
else if c < 0 then a :: (assoc_remove_aux v r l)
else raise Not_found
| [] -> raise Not_found
let assoc_remove v l =
let r = ref (Obj.magic 0) in
let l = assoc_remove_aux v r l in
(!r, l)
let rec merge f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
......@@ -278,6 +298,10 @@ module Map = struct
| (x,y)::l -> (x, f y)::(map f l)
| [] -> []
let rec mapi f = function
| (x,y)::l -> (x, f x y)::(mapi f l)
| [] -> []
let rec mapi_to_list f = function
| (x,y)::l -> (f x y) ::(mapi_to_list f l)
| [] -> []
......
......@@ -56,8 +56,10 @@ sig
type ('a,'b) map
external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
val empty: ('a,'b) map
val iter: ('b -> unit) -> ('a,'b) map -> unit
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
......@@ -67,6 +69,7 @@ sig
val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map
val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map
val constant: 'b -> 'a t -> ('a,'b) map
val num: int -> 'a t -> ('a,int) map
val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
......
open Recursive
open Printf
open Ident
let map_sort f l =
SortedList.from_list (List.map f l)
......@@ -12,10 +12,6 @@ struct
let equal = (=)
end
module LabelPool = Pool.Make(SortedList.String)
module X = SortedList.Make(SortedList.Lift(LabelPool))
type label = LabelPool.t
type const =
| Integer of Intervals.v
......@@ -36,7 +32,45 @@ module NodePair = struct
let hash (x,y) = x.id + 17 * y.id
end
module RecArg = struct
type 'a t = bool * 'a node0 label_map
let rec compare_rec r1 r2 =
if r1 == r2 then 0
else match (r1,r2) with
| (l1,x1)::r1,(l2,x2)::r2 ->
if ((l1:int) < l2) then -1
else if (l1 > l2) then 1
else if x1.id < x2.id then -1
else if x1.id > x2.id then 1
else compare_rec r1 r2
| ([],_) -> -1
| _ -> 1
let compare (o1,r1) (o2,r2) =
if o1 && not o2 then -1
else if o2 && not o1 then 1
else compare_rec (LabelMap.get r1) (LabelMap.get r2)
let rec equal_rec r1 r2 =
(r1 == r2) ||
match (r1,r2) with
| (l1,x1)::r1,(l2,x2)::r2 ->
(x1.id == x2.id) && (l1 == l2) && (equal_rec r1 r2)
| _ -> false
let equal (o1,r1) (o2,r2) =
(o1 == o2) && (equal_rec (LabelMap.get r1) (LabelMap.get r2))
let rec hash_rec accu = function
| (l,x)::rem -> hash_rec (257 * accu + 17 * l + x.id) rem
| [] -> accu + 5
let hash (o,r) = hash_rec (if o then 2 else 1) (LabelMap.get r)
end
module BoolPair = Boolean.Make(NodePair)
module BoolRec = Boolean.Make(RecArg)
type descr = {
atoms : Atoms.t;
......@@ -45,7 +79,7 @@ type descr = {
times : descr BoolPair.t;
xml : descr BoolPair.t;
arrow : descr BoolPair.t;
record: (bool * (label, node) SortedMap.t) Boolean.t;
record: descr BoolRec.t;
absent: bool
} and node = descr node0
......@@ -54,7 +88,7 @@ let empty = {
times = BoolPair.empty;
xml = BoolPair.empty;
arrow = BoolPair.empty;
record= Boolean.empty;
record= BoolRec.empty;
ints = Intervals.empty;
atoms = Atoms.empty;
chars = Chars.empty;
......@@ -65,7 +99,7 @@ let any = {
times = BoolPair.full;
xml = BoolPair.full;
arrow = BoolPair.full;
record= Boolean.full;
record= BoolRec.full;
ints = Intervals.any;
atoms = Atoms.any;
chars = Chars.any;
......@@ -78,9 +112,9 @@ let times x y = { empty with times = BoolPair.atom (x,y) }
let xml x y = { empty with xml = BoolPair.atom (x,y) }
let arrow x y = { empty with arrow = BoolPair.atom (x,y) }
let record label t =
{ empty with record = Boolean.atom (true,[label,t]) }
let record' x =
{ empty with record = Boolean.atom x }
{ empty with record = BoolRec.atom (true,LabelMap.singleton label t) }
let record' (x : bool * node Ident.label_map) =
{