Commit 4cbdc1e1 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-21 07:15:03 by afrisch] Empty log message

Original author: afrisch
Date: 2005-02-21 07:15:04+00:00
parent f881fc81
...@@ -60,3 +60,34 @@ module Counter = struct ...@@ -60,3 +60,34 @@ module Counter = struct
let incr c = let incr c =
c.count <- c.count + 1 c.count <- c.count + 1
end end
module InOut = struct
let h = Hashtbl.create 17
let enter s =
let i = try Hashtbl.find h s with Not_found ->
let r = ref 0 in
Hashtbl.add h s r;
r in
incr i;
Printf.printf "+%s[%i] " s !i;
flush stdout
let leave s =
let i = try Hashtbl.find h s with Not_found -> assert false in
decr i;
Printf.printf "-%s[%i] " s !i;
flush stdout
let wrap s f x =
enter s;
try
let r = f x in
leave s;
r
with exn ->
leave s;
raise exn
end
...@@ -20,3 +20,10 @@ module Timer: sig ...@@ -20,3 +20,10 @@ module Timer: sig
val stop: t -> 'a -> 'a val stop: t -> 'a -> 'a
val print: Format.formatter -> t -> unit val print: Format.formatter -> t -> unit
end end
module InOut: sig
val enter: string -> unit
val leave: string -> unit
val wrap: string -> ('a -> 'b) -> 'a -> 'b
end
...@@ -214,7 +214,7 @@ let print_element fmt { elt_uid = id; elt_name = name } = ...@@ -214,7 +214,7 @@ let print_element fmt { elt_uid = id; elt_name = name } =
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute) let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt ag = let print_attribute_group fmt ag =
Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
let print_model_group fmt mg = let print_model_group_def fmt mg =
Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name
let print_schema fmt schema = let print_schema fmt schema =
let defined_types = (* filter out built-in types *) let defined_types = (* filter out built-in types *)
...@@ -248,7 +248,7 @@ let print_schema fmt schema = ...@@ -248,7 +248,7 @@ let print_schema fmt schema =
end; end;
if schema.model_groups <> [] then begin if schema.model_groups <> [] then begin
Format.fprintf fmt "Model groups: "; Format.fprintf fmt "Model groups: ";
List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ") List.iter (fun c -> print_model_group_def fmt c; Format.fprintf fmt " ")
schema.model_groups; schema.model_groups;
Format.fprintf fmt "\n" Format.fprintf fmt "\n"
end end
...@@ -421,3 +421,17 @@ let test v = ...@@ -421,3 +421,17 @@ let test v =
aux () aux ()
*) *)
let rec print_model_group ppf = function
| All pl -> Format.fprintf ppf "All(%a)" print_particle_list pl
| Choice pl -> Format.fprintf ppf "Choice(%a)" print_particle_list pl
| Sequence pl -> Format.fprintf ppf "Sequence(%a)" print_particle_list pl
and print_particle_list ppf = function
| [] -> ()
| [p] -> print_particle ppf p
| hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl
and print_particle ppf (min,max,term,_) =
print_term ppf term
and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid)
| Model m -> print_model_group ppf m
...@@ -17,7 +17,7 @@ val print_attribute : Format.formatter -> attribute_declaration -> unit ...@@ -17,7 +17,7 @@ val print_attribute : Format.formatter -> attribute_declaration -> unit
val print_element : Format.formatter -> element_declaration -> unit val print_element : Format.formatter -> element_declaration -> unit
val print_attribute_group : val print_attribute_group :
Format.formatter -> attribute_group_definition -> unit Format.formatter -> attribute_group_definition -> unit
val print_model_group : Format.formatter -> model_group_definition -> unit val print_model_group_def : Format.formatter -> model_group_definition -> unit
val print_simple_type : Format.formatter -> simple_type_definition -> unit val print_simple_type : Format.formatter -> simple_type_definition -> unit
val print_complex_type : Format.formatter -> complex_type_definition -> unit val print_complex_type : Format.formatter -> complex_type_definition -> unit
...@@ -93,3 +93,7 @@ val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t ...@@ -93,3 +93,7 @@ val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t
val stream_of_value: Value.t -> event Stream.t val stream_of_value: Value.t -> event Stream.t
val string_of_event: event -> string val string_of_event: event -> string
val print_model_group: Format.formatter -> model_group -> unit
val print_particle: Format.formatter -> particle -> unit
...@@ -8,6 +8,12 @@ open Location ...@@ -8,6 +8,12 @@ open Location
open Ast open Ast
open Ident open Ident
let (=) (x:int) y = x = y
let (<=) (x:int) y = x <= y
let (<) (x:int) y = x < y
let (>=) (x:int) y = x >= y
let (>) (x:int) y = x > y
let debug_schema = false let debug_schema = false
let warning loc msg = let warning loc msg =
...@@ -274,7 +280,7 @@ type derecurs_slot = { ...@@ -274,7 +280,7 @@ type derecurs_slot = {
} and derecurs = } and derecurs =
| PDummy | PDummy
| PAlias of derecurs_slot | PAlias of derecurs_slot
| PType of Types.descr | PType of Types.descr * int
| POr of derecurs * derecurs | POr of derecurs * derecurs
| PAnd of derecurs * derecurs | PAnd of derecurs * derecurs
| PDiff of derecurs * derecurs | PDiff of derecurs * derecurs
...@@ -295,9 +301,34 @@ and derecurs_regexp = ...@@ -295,9 +301,34 @@ and derecurs_regexp =
| PStar of derecurs_regexp | PStar of derecurs_regexp
| PWeakStar of derecurs_regexp | PWeakStar of derecurs_regexp
let rec print_derecurs ppf = function
| PDummy -> Format.fprintf ppf "Dummy"
| PAlias a -> Format.fprintf ppf "Alias %i" a.pid
| PType _ -> Format.fprintf ppf "Type"
| POr (r1,r2) -> Format.fprintf ppf "Or(%a,%a)"
print_derecurs r1 print_derecurs r2
| PAnd (r1,r2) -> Format.fprintf ppf "And(%a,%a)"
print_derecurs r1 print_derecurs r2
| PDiff (r1,r2) -> Format.fprintf ppf "Diff(%a,%a)"
print_derecurs r1 print_derecurs r2
| PTimes (r1,r2) -> Format.fprintf ppf "Times(%a,%a)"
print_derecurs r1 print_derecurs r2
| PXml (r1,r2) -> Format.fprintf ppf "Xml(%a,%a)"
print_derecurs r1 print_derecurs r2
| PRegexp r -> Format.fprintf ppf "Regexp(%a)" print_regexp r
| _ -> Format.fprintf ppf "Other"
and print_regexp ppf = function
| PEpsilon -> Format.fprintf ppf "e"
| PElem r -> Format.fprintf ppf "(%a)" print_derecurs r
| PGuard r -> Format.fprintf ppf "/(%a)" print_derecurs r
| PSeq (r1,r2) -> Format.fprintf ppf "%a,%a" print_regexp r1 print_regexp r2
| PAlt (r1,r2) -> Format.fprintf ppf "%a|%a" print_regexp r1 print_regexp r2
| PStar r | PWeakStar r -> Format.fprintf ppf "%a*" print_regexp r
type descr = type descr =
| IDummy | IDummy
| IType of Types.descr | IType of Types.descr * int
| IOr of descr * descr | IOr of descr * descr
| IAnd of descr * descr | IAnd of descr * descr
| IDiff of descr * descr | IDiff of descr * descr
...@@ -338,8 +369,8 @@ let rec hash_derecurs = function ...@@ -338,8 +369,8 @@ let rec hash_derecurs = function
| PDummy -> assert false | PDummy -> assert false
| PAlias s -> | PAlias s ->
s.pid s.pid
| PType t -> | PType (t,hash) ->
1 + 17 * (Types.hash t) 1 + 17 * hash
| POr (p1,p2) -> | POr (p1,p2) ->
2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2) 2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PAnd (p1,p2) -> | PAnd (p1,p2) ->
...@@ -384,8 +415,8 @@ and hash_derecurs_regexp = function ...@@ -384,8 +415,8 @@ and hash_derecurs_regexp = function
let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
| PAlias s1, PAlias s2 -> | PAlias s1, PAlias s2 ->
s1 == s2 s1 == s2
| PType t1, PType t2 -> | PType (t1,h1), PType (t2,h2) ->
Types.equal t1 t2 (h1 == h2) && (Types.equal t1 t2)
| POr (p1,q1), POr (p2,q2) | POr (p1,q1), POr (p2,q2)
| PAnd (p1,q1), PAnd (p2,q2) | PAnd (p1,q1), PAnd (p2,q2)
| PDiff (p1,q1), PDiff (p2,q2) | PDiff (p1,q1), PDiff (p2,q2)
...@@ -436,7 +467,7 @@ let rank = ref 0 ...@@ -436,7 +467,7 @@ let rank = ref 0
let rec hash_descr = function let rec hash_descr = function
| IDummy -> assert false | IDummy -> assert false
| IType x -> Types.hash x | IType (t,h) -> h
| IOr (d1,d2) -> 1 + 17 * (hash_descr d1) + 257 * (hash_descr d2) | IOr (d1,d2) -> 1 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
| IAnd (d1,d2) -> 2 + 17 * (hash_descr d1) + 257 * (hash_descr d2) | IAnd (d1,d2) -> 2 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
| IDiff (d1,d2) -> 3 + 17 * (hash_descr d1) + 257 * (hash_descr d2) | IDiff (d1,d2) -> 3 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
...@@ -460,7 +491,7 @@ and hash_slot s = ...@@ -460,7 +491,7 @@ and hash_slot s =
let rec equal_descr d1 d2 = let rec equal_descr d1 d2 =
match (d1,d2) with match (d1,d2) with
| IType x1, IType x2 -> Types.equal x1 x2 | IType (x1,h1), IType (x2,h2) -> (h1 == h2) && (Types.equal x1 x2)
| IOr (x1,y1), IOr (x2,y2) | IOr (x1,y1), IOr (x2,y2)
| IAnd (x1,y1), IAnd (x2,y2) | IAnd (x1,y1), IAnd (x2,y2)
| IDiff (x1,y1), IDiff (x2,y2) -> (equal_descr x1 x2) && (equal_descr y1 y2) | IDiff (x1,y1), IDiff (x2,y2) -> (equal_descr x1 x2) && (equal_descr y1 y2)
...@@ -469,7 +500,7 @@ let rec equal_descr d1 d2 = ...@@ -469,7 +500,7 @@ let rec equal_descr d1 d2 =
| IXml (x1,y1), IXml (x2,y2) | IXml (x1,y1), IXml (x2,y2)
| IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2) | IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
| IRecord (o1,r1), IRecord (o2,r2) -> | IRecord (o1,r1), IRecord (o2,r2) ->
(o1 = o2) && (LabelMap.equal equal_descr_field r1 r2) (o1 == o2) && (LabelMap.equal equal_descr_field r1 r2)
| ICapture x1, ICapture x2 -> Id.equal x1 x2 | ICapture x1, ICapture x2 -> Id.equal x1 x2
| IConstant (x1,y1), IConstant (x2,y2) -> | IConstant (x1,y1), IConstant (x2,y2) ->
(Id.equal x1 x2) && (Types.Const.equal y1 y2) (Id.equal x1 x2) && (Types.Const.equal y1 y2)
...@@ -509,8 +540,9 @@ module SlotTable = Hashtbl.Make( ...@@ -509,8 +540,9 @@ module SlotTable = Hashtbl.Make(
e) e)
end) end)
let ptype t = PType (t, Types.hash t)
let pempty = PType Types.empty let pempty = ptype Types.empty
let por p1 p2 = let por p1 p2 =
if p1 == pempty then p2 else if p1 == pempty then p2 else
...@@ -578,10 +610,10 @@ let rec derecurs env p = match p.descr with ...@@ -578,10 +610,10 @@ let rec derecurs env p = match p.descr with
| PatVar v -> derecurs_var env p.loc v | PatVar v -> derecurs_var env p.loc v
| SchemaVar (kind, schema_name, component_name) -> | SchemaVar (kind, schema_name, component_name) ->
let name = qname env.penv_tenv p.loc component_name in let name = qname env.penv_tenv p.loc component_name in
PType (find_schema_descr env.penv_tenv kind schema_name name) ptype (find_schema_descr env.penv_tenv kind schema_name name)
| Recurs (p,b) -> derecurs (derecurs_def env b) p | Recurs (p,b) -> derecurs (derecurs_def env b) p
| Internal t -> PType t | Internal t -> ptype t
| NsT ns -> PType (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns))) | NsT ns -> ptype (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
| Or (p1,p2) -> POr (derecurs env p1, derecurs env p2) | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
| And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2) | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)
| Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2) | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)
...@@ -595,7 +627,7 @@ let rec derecurs env p = match p.descr with ...@@ -595,7 +627,7 @@ let rec derecurs env p = match p.descr with
| (p,None) -> derecurs env p, None in | (p,None) -> derecurs env p, None in
PRecord (o, parse_record env.penv_tenv p.loc aux r) PRecord (o, parse_record env.penv_tenv p.loc aux r)
| Constant (x,c) -> PConstant (x,const env.penv_tenv p.loc c) | Constant (x,c) -> PConstant (x,const env.penv_tenv p.loc c)
| Cst c -> PType (Types.constant (const env.penv_tenv p.loc c)) | Cst c -> ptype (Types.constant (const env.penv_tenv p.loc c))
| Regexp r -> | Regexp r ->
let r,_ = derecurs_regexp IdSet.empty false IdSet.empty true env r in let r,_ = derecurs_regexp IdSet.empty false IdSet.empty true env r in
PRegexp r PRegexp r
...@@ -650,12 +682,12 @@ and derecurs_var env loc v = ...@@ -650,12 +682,12 @@ and derecurs_var env loc v =
let v = ident v in let v = ident v in
(try PAlias (Env.find v env.penv_derec) (try PAlias (Env.find v env.penv_derec)
with Not_found -> with Not_found ->
try PType (find_type v env.penv_tenv) try ptype (find_type v env.penv_tenv)
with Not_found -> PCapture v) with Not_found -> PCapture v)
| cu, v -> | cu, v ->
try try
let cu = U.mk cu in let cu = U.mk cu in
PType (find_type_global loc cu (ident v) env.penv_tenv) ptype (find_type_global loc cu (ident v) env.penv_tenv)
with Not_found -> with Not_found ->
raise_loc_generic loc raise_loc_generic loc
("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)) ("Unbound external type " ^ cu ^ ":" ^ (U.to_string v))
...@@ -707,18 +739,24 @@ let check_no_capture loc s = ...@@ -707,18 +739,24 @@ let check_no_capture loc s =
raise_loc_generic loc ("Capture variable not allowed: " ^ (Ident.to_string x)) raise_loc_generic loc ("Capture variable not allowed: " ^ (Ident.to_string x))
| None -> () | None -> ()
let compile_slot_hash = DerecursTable.create 67 let compile_slot_hash = DerecursTable.create 15067
let compile_hash = DerecursTable.create 67 let compile_hash = DerecursTable.create 15067
let todo_defs = ref [] let todo_defs = ref []
let todo_fv = ref [] let todo_fv = ref []
let rec compile p = let rec compile p =
try DerecursTable.find compile_hash p real_compile p
(*
print_char '*'; flush stdout;
try Stats.InOut.wrap "lookup" (DerecursTable.find compile_hash) p;
with Not_found -> with Not_found ->
Stats.InOut.enter "compile";
let c = real_compile p in let c = real_compile p in
DerecursTable.replace compile_hash p c; DerecursTable.replace compile_hash p c;
Stats.InOut.leave "compile";
c c
*)
and real_compile = function and real_compile = function
| PDummy -> assert false | PDummy -> assert false
| PAlias v -> | PAlias v ->
...@@ -728,7 +766,7 @@ and real_compile = function ...@@ -728,7 +766,7 @@ and real_compile = function
let r = compile v.pdescr in let r = compile v.pdescr in
v.ploop <- false; v.ploop <- false;
r r
| PType t -> IType t | PType (t,h) -> IType (t,h)
| POr (t1,t2) -> IOr (compile t1, compile t2) | POr (t1,t2) -> IOr (compile t1, compile t2)
| PAnd (t1,t2) -> IAnd (compile t1, compile t2) | PAnd (t1,t2) -> IAnd (compile t1, compile t2)
| PDiff (t1,t2) -> IDiff (compile t1, compile t2) | PDiff (t1,t2) -> IDiff (compile t1, compile t2)
...@@ -739,7 +777,7 @@ and real_compile = function ...@@ -739,7 +777,7 @@ and real_compile = function
| PRecord (o,r) -> IRecord (o, LabelMap.map compile_field r) | PRecord (o,r) -> IRecord (o, LabelMap.map compile_field r)
| PConstant (x,v) -> IConstant (x,v) | PConstant (x,v) -> IConstant (x,v)
| PCapture x -> ICapture x | PCapture x -> ICapture x
| PRegexp r -> compile (remove_regexp r (PType Sequence.nil_type)) | PRegexp r -> compile (remove_regexp r (ptype Sequence.nil_type))
and compile_field = function and compile_field = function
| (p, Some e) -> (compile_slot p, Some (compile e)) | (p, Some e) -> (compile_slot p, Some (compile e))
...@@ -763,7 +801,9 @@ let rec flush_defs () = ...@@ -763,7 +801,9 @@ let rec flush_defs () =
List.iter compute_fv !todo_fv; List.iter compute_fv !todo_fv;
todo_fv := []; todo_fv := [];
Stats.Timer.stop timer_fv () Stats.Timer.stop timer_fv ()
| (s,p)::t -> | (s,p)::t ->
(* Format.fprintf Format.std_formatter "flush slot:%a@."
print_derecurs p; *)
todo_defs := t; todo_defs := t;
s.d <- compile p; s.d <- compile p;
flush_defs () flush_defs ()
...@@ -772,7 +812,7 @@ let typ_nodes = SlotTable.create 67 ...@@ -772,7 +812,7 @@ let typ_nodes = SlotTable.create 67
let pat_nodes = SlotTable.create 67 let pat_nodes = SlotTable.create 67
let rec typ = function let rec typ = function
| IType t -> t | IType (t,_) -> t
| IOr (s1,s2) -> Types.cup (typ s1) (typ s2) | IOr (s1,s2) -> Types.cup (typ s1) (typ s2)
| IAnd (s1,s2) -> Types.cap (typ s1) (typ s2) | IAnd (s1,s2) -> Types.cap (typ s1) (typ s2)
| IDiff (s1,s2) -> Types.diff (typ s1) (typ s2) | IDiff (s1,s2) -> Types.diff (typ s1) (typ s2)
...@@ -903,6 +943,10 @@ let dump_ns ppf env = ...@@ -903,6 +943,10 @@ let dump_ns ppf env =
let do_typ loc r = let do_typ loc r =
(*
DerecursTable.clear compile_slot_hash;
DerecursTable.clear compile_hash;
*)
let s = compile_slot r in let s = compile_slot r in
flush_defs (); flush_defs ();
check_no_capture loc (fv_slot s); check_no_capture loc (fv_slot s);
...@@ -916,7 +960,8 @@ let pat env p = ...@@ -916,7 +960,8 @@ let pat env p =
flush_defs (); flush_defs ();
try pat_node s try pat_node s
with Patterns.Error e -> raise_loc_generic p.loc e with Patterns.Error e -> raise_loc_generic p.loc e
| Location (loc,_,exn) when loc = noloc -> raise (Location (p.loc, `Full, exn)) | Location (loc,_,exn) when loc == noloc ->
raise (Location (p.loc, `Full, exn))
(* II. Build skeleton *) (* II. Build skeleton *)
...@@ -1033,7 +1078,8 @@ and extern loc env s args = ...@@ -1033,7 +1078,8 @@ and extern loc env s args =
and var env loc s = and var env loc s =
match is_op env s with match is_op env s with
| Some (s,arity) -> | Some (s,arity) ->
let need_ns = s = "print_xml" || s = "print_xml_utf8" in let need_ns = match s with "print_xml" | "print_xml_utf8" -> true
| _ -> false in
let e = Typed.Op (s, arity, []) in let e = Typed.Op (s, arity, []) in
let e = if need_ns then Typed.NsTable (env.ns,e) else e in let e = if need_ns then Typed.NsTable (env.ns,e) else e in
exp loc Fv.empty e exp loc Fv.empty e
...@@ -1111,7 +1157,7 @@ and branches env b = ...@@ -1111,7 +1157,7 @@ and branches env b =
let br = let br =
{ {
Typed.br_loc = br_loc; Typed.br_loc = br_loc;
Typed.br_used = br_loc = noloc; Typed.br_used = br_loc == noloc;
Typed.br_vars_empty = Patterns.fv p'; Typed.br_vars_empty = Patterns.fv p';
Typed.br_pat = p'; Typed.br_pat = p';
Typed.br_body = e } in Typed.br_body = e } in
...@@ -1468,7 +1514,7 @@ let rec unused_branches b = ...@@ -1468,7 +1514,7 @@ let rec unused_branches b =
List.map List.map
(fun x -> (fun x ->
let x = Ident.to_string x in let x = Ident.to_string x in
if x = "$$$" then raise Exit else x) if (String.compare x "$$$" = 0) then raise Exit else x)
(IdSet.get br.br_vars_empty) in (IdSet.get br.br_vars_empty) in
let l = String.concat "," l in let l = String.concat "," l in
"The following variables always match the empty sequence: " ^ "The following variables always match the empty sequence: " ^
...@@ -1538,19 +1584,23 @@ module Schema_converter = ...@@ -1538,19 +1584,23 @@ module Schema_converter =
open Schema_types open Schema_types
open Encodings open Encodings
let seq r1 r2 = match r1,r2 with
| PEpsilon, r | r, PEpsilon -> r
| r1,r2 -> PSeq (r1,r2)
let xsd = Schema_xml.xsd let xsd = Schema_xml.xsd
let is_xsd (ns,l) local = let is_xsd (ns,l) local =
(Ns.equal ns xsd) && (Utf8.get_str l = local) (Ns.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)
(* auxiliary functions *) (* auxiliary functions *)
let nil_type = PType Sequence.nil_type let nil_type = ptype Sequence.nil_type
let mk_len_regexp ?min ?max base = let mk_len_regexp ?min ?max base =
let rec repeat_regexp re = function let rec repeat_regexp re = function
| z when Intervals.V.is_zero z -> PEpsilon | z when Intervals.V.is_zero z -> PEpsilon
| n when Intervals.V.gt n Intervals.V.zero -> | n when Intervals.V.gt n Intervals.V.zero ->
PSeq (re, repeat_regexp re (Intervals.V.pred n)) seq re (repeat_regexp re (Intervals.V.pred n))
| _ -> assert false | _ -> assert false
in in
let min = match min with Some min -> min | _ -> Intervals.V.one in let min = match min with Some min -> min | _ -> Intervals.V.one in
...@@ -1561,10 +1611,10 @@ module Schema_converter = ...@@ -1561,10 +1611,10 @@ module Schema_converter =
let rec aux acc = function let rec aux acc = function
| z when Intervals.V.is_zero z -> acc | z when Intervals.V.is_zero z -> acc
| n -> | n ->
aux (PAlt (PEpsilon, (PSeq (base, acc)))) (Intervals.V.pred n) aux (PAlt (PEpsilon, (seq base acc))) (Intervals.V.pred n)
in in
PSeq (min_regexp, aux PEpsilon (Intervals.V.sub max min)) seq min_regexp (aux PEpsilon (Intervals.V.sub max min))
| None -> PSeq (min_regexp, PStar base) | None -> seq min_regexp (PStar base)
(* given a base derecurs create a derecurs value representing a sequence (* given a base derecurs create a derecurs value representing a sequence
* type according to length constraints members of facets *) * type according to length constraints members of facets *)
...@@ -1580,22 +1630,22 @@ module Schema_converter = ...@@ -1580,22 +1630,22 @@ module Schema_converter =
(* This is not correct ! *) (* This is not correct ! *)
let mix_regexp = let mix_regexp =
let pcdata = PStar (PElem (PType Builtin_defs.string)) in let pcdata = PStar (PElem (ptype Builtin_defs.string)) in
let rec aux = function let rec aux = function
| PEpsilon -> PEpsilon | PEpsilon -> PEpsilon
| PElem re -> PElem re | PElem re -> PElem re
| PGuard re -> PGuard re | PGuard re -> PGuard re
| PSeq (re1, re2) -> PSeq (aux re1, PSeq (pcdata, aux re2)) | PSeq (re1, re2) -> seq (aux re1) (seq pcdata (aux re2))
| PAlt (re1, re2) -> PAlt (aux re1, aux re2) | PAlt (re1, re2) -> PAlt (aux re1, aux re2)
| PStar re -> PStar (aux re) | PStar re -> PStar (aux re)
| PWeakStar re -> PWeakStar (aux re) | PWeakStar re -> PWeakStar (aux re)
in in
let rec simplify = function let rec simplify = function
| PSeq (x1, PSeq (x2, y)) when x1 = pcdata && x2 = pcdata -> | PSeq (x1, PSeq (x2, y)) when x1 == pcdata && x2 == pcdata ->
simplify (PSeq (x2, y)) simplify (seq x2 y)