Commit f2eb8125 authored by Pietro Abate's avatar Pietro Abate

[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 68ce5b26
......@@ -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
......
This diff is collapsed.
module LabelPool : Pool.T with type value = string and type t = int
type label = LabelPool.t
open Ident
type const = | Integer of Intervals.v
| Atom of Atoms.v
| Char of Chars.v
......@@ -48,7 +48,7 @@ val times : node -> node -> descr
val xml : node -> node -> descr
val arrow : node -> node -> descr
val record : label -> node -> descr
val record' : bool * (label, node) SortedMap.t -> descr
val record' : bool * node label_map -> descr
val char : Chars.t -> descr
val constant : const -> descr
......
......@@ -30,13 +30,13 @@ and texpr' =
| Cst of Types.const
| Pair of texpr * texpr
| Xml of texpr * texpr
| RecordLitt of (Types.label, texpr) SortedMap.t
| RecordLitt of texpr label_map
(* Data destructors *)
| Op of string * texpr list
| Match of texpr * branches
| Map of texpr * branches
| Dot of (texpr * Types.label)
| Dot of texpr * label
(* Exception *)
| Try of texpr * branches
......
......@@ -13,10 +13,9 @@ module StringSet = Set.Make(S)
*)
exception NonExhaustive of Types.descr
exception MultipleLabel of Types.label
exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label
exception WrongLabel of Types.descr * label
exception UnboundId of string
let raise_loc loc exn = raise (Location (loc,exn))
......@@ -43,7 +42,7 @@ and descr =
| IXml of ti * ti
| IArrow of ti * ti
| IOptional of ti
| IRecord of bool * (Types.label * ti) list
| IRecord of bool * ti label_map
| ICapture of id
| IConstant of id * Types.const
......@@ -266,8 +265,7 @@ let rec compile env { loc = loc; descr = d } : ti =
| XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))
| Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))
| Optional t -> cons loc (IOptional (compile env t))
| Record (o,r) ->
cons loc (IRecord (o, List.map (fun (l,t) -> l,compile env t) r))
| Record (o,r) -> cons loc (IRecord (o, LabelMap.map (compile env) r))
| Constant (x,v) -> cons loc (IConstant (x,v))
| Capture x -> cons loc (ICapture x)
......@@ -301,7 +299,7 @@ let rec comp_fv s =
| ITimes (s1,s2) | IXml (s1,s2)
| IArrow (s1,s2) -> comp_fv s1; comp_fv s2
| IOptional r -> comp_fv r
| IRecord (_,r) -> List.iter (fun (l,s) -> comp_fv s) r
| IRecord (_,r) -> LabelMap.iter comp_fv r
| IType _ -> ()
| ICapture x
| IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res
......@@ -337,7 +335,7 @@ let rec typ seen s : Types.descr =
| IOptional s -> Types.Record.or_absent (typ seen s)
| IRecord (o,r) ->
Types.record'
(o,List.map (fun (l,s) -> (l,typ_node s)) r)
(o, LabelMap.map typ_node r)
| ICapture x | IConstant (x,_) -> assert false
and typ_node s : Types.node =
......@@ -387,14 +385,13 @@ and pat_aux seen s = match s.descr' with
"Optional field not allowed in record patterns")
| IRecord (o,r) ->
let pats = ref [] in
let aux (l,s) =
if IdSet.is_empty (fv s) then (l,type_node s)
let aux l s =
if IdSet.is_empty (fv s) then type_node s
else
(
pats := Patterns.record l (pat_node s) :: !pats;
(l,Types.any_node)
) in
let constr = Types.record' (o,List.map aux r) in
( pats := Patterns.record l (pat_node s) :: !pats;
Types.any_node )
in
let constr = Types.record' (o,LabelMap.mapi aux r) in
List.fold_left Patterns.cap (Patterns.constr constr) !pats
(* TODO: can avoid constr when o=true, and all fields have fv *)
| ICapture x -> Patterns.capture x
......@@ -491,18 +488,11 @@ let rec expr loc' glb { loc = loc; descr = d } =
(fv, Typed.Dot (e,l))
| RecordLitt r ->
let fv = ref Fv.empty in
let r = List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r in
let r = List.map
(fun (l,e) ->
let r = LabelMap.map
(fun e ->
let (fv2,e) = expr loc glb e
in fv := Fv.cup !fv fv2; (l,e))
in fv := Fv.cup !fv fv2; e)
r in
let rec check = function
| (l1,_) :: (l2,_) :: _ when l1 = l2 ->
raise_loc loc (MultipleLabel l1)
| _ :: rem -> check rem
| _ -> () in
check r;
(!fv, Typed.RecordLitt r)
| Op (op,le) ->
let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
......@@ -636,7 +626,7 @@ and type_check' loc env e constr precise = match e with
raise_loc loc
(ShouldHave (constr,(Printf.sprintf
"Field %s is not allowed here."
(Types.LabelPool.value l)
(LabelPool.value l)
)
));
let t = type_check env e pi true in
......@@ -794,10 +784,7 @@ and compute_type' loc env = function
and t2 = compute_type env e2 in
Types.times (Types.cons t1) (Types.cons t2)
| RecordLitt r ->
let r =