Commit 4059b145 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-20 21:05:15 by afrisch] Use lazy to resolve circularities

Original author: afrisch
Date: 2005-02-20 21:05:16+00:00
parent d37272f3
......@@ -425,11 +425,11 @@ let restrict' name basename new_facets =
let facets =
merge_facets (facets_of_simple_type_definition base) new_facets
in
Derived (Some name, variety, facets, ref (Simple base))
Derived (Some name, variety, facets, lazy (Simple base))
let list' name itemname =
let (name, itemname) = (add_xsd_prefix name, add_xsd_prefix itemname) in
let (base, _, _) = QTable.find builtins itemname in
let base = ref (Simple base) in
let base = lazy (Simple base) in
Derived (Some name, List base, no_facets, base)
let fill () = (* fill "builtins" hashtbl *)
......
......@@ -67,13 +67,13 @@ let rec facets_of_simple_type_definition = function
| Derived (_, _, facets, _) -> facets
let rec variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic (ref (Simple st))
| (Primitive name) as st -> Atomic (lazy (Simple st))
| Derived (_, variety, _, _) -> variety
let get_simple_type = function
| { contents = Simple c } -> c
| { contents = AnyType } -> Primitive (xsd,Utf8.mk "anySimpleType")
let get_simple_type c = match Lazy.force c with
| Simple c -> c
| AnyType -> Primitive (xsd,Utf8.mk "anySimpleType")
| _ -> assert false
let rec normalize_simple_type = function
......@@ -82,7 +82,7 @@ let rec normalize_simple_type = function
| Derived (_,variety,old_facets,base) ->
Derived (name,variety,merge_facets old_facets new_facets,base)
| Primitive _ as st ->
let b = ref (Simple st) in
let b = lazy (Simple st) in
Derived (name,Atomic b,new_facets,b))
| st -> st
......@@ -103,10 +103,10 @@ let name_of_attribute_use { attr_decl = { attr_name = name } } = name
let name_of_attribute_group_definition ag = ag.ag_name
let name_of_model_group_definition mg = mg.mg_name
let name_of_particle = function
| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration !elt_decl_ref
| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration (Lazy.force elt_decl_ref)
| _ -> assert false
let variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic (ref (Simple st))
| (Primitive name) as st -> Atomic (lazy (Simple st))
| Derived (_, variety, _, _) -> variety
let simple_type_of_type = function
| Simple s -> s
......@@ -117,7 +117,7 @@ let complex_type_of_type = function
let content_type_of_type = function
| AnyType -> assert false
| Complex { ct_content = ct } -> ct
| Simple st -> CT_simple (ref (Simple st))
| Simple st -> CT_simple (lazy (Simple st))
let iter_types schema f = List.iter f schema.types
let iter_attributes schema f = List.iter f schema.attributes
......
......@@ -13,6 +13,7 @@ let validation_error s = raise (XSD_validation_error s)
let xsd = Schema_xml.xsd
(*
let fake_type_def =
Complex
{ ct_uid = -1;
......@@ -28,6 +29,8 @@ let fake_elt_decl =
elt_cstr = None }
let is_fake_type_def = (==) fake_type_def
let is_fake_elt_decl = (==) fake_elt_decl
*)
let (^^) x y = Utf8.concat x y
(* element and complex type constructors which take cares of unique id *)
......@@ -56,7 +59,7 @@ let split s = pcre_split ~rex:space_RE s
let unqualify s = snd (Ns.split_qname s)
let hashtbl_deref tbl = QTable.fold (fun _ v acc -> !v :: acc) tbl []
let hashtbl_deref tbl = QTable.fold (fun _ v acc -> (Lazy.force v) :: acc) tbl []
let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
let parse_facets base n =
......@@ -154,8 +157,8 @@ let register_builtins typs =
(fun st_def ->
let type_def = Simple st_def in
let name = name_of_type_definition type_def in
QTable.replace typs name (ref type_def));
QTable.replace typs (xsd, Utf8.mk "anyType") (ref AnyType)
QTable.replace typs name (lazy type_def));
QTable.replace typs (xsd, Utf8.mk "anyType") (lazy AnyType)
(* Main parsing function *)
let schema_of_uri uri =
......@@ -207,12 +210,12 @@ let schema_of_uri uri =
| None -> None in
let get_name n = (targetNamespace, _attr "name" n) in
let rec resolve_typ qname =
let rec resolve_typ qname : Schema_types.type_definition lazy_t =
try QTable.find typs qname
with Not_found ->
failwith ("Cannot find type " ^ (Ns.QName.to_string qname))
and resolve_simple_typ qname =
and resolve_simple_typ qname : Schema_types.type_definition lazy_t =
resolve_typ qname
and resolve_elt qname =
......@@ -243,16 +246,16 @@ let schema_of_uri uri =
match _may_elem "xsd:list" n with
| Some list ->
let items = find_item_type list in
Simple (Derived (name, List items, no_facets, ref (Simple anySimpleType)))
Simple (Derived (name, List items, no_facets, lazy (Simple anySimpleType)))
| None ->
match _may_elem "xsd:union" n with
| Some union ->
let members = find_member_types union in
Simple (Derived (name, Union members, no_facets, ref (Simple anySimpleType)))
Simple (Derived (name, Union members, no_facets, lazy (Simple anySimpleType)))
| None ->
assert false
failwith ("Unknown variety for simpleType at line " ^ (string_of_int (_line n)) ^ " uri = " ^ uri)
and parse_simple_type n =
ref (parse_simple_type_def n)
lazy (parse_simple_type_def n)
(* look for a simple type def: try attribute "base", try "simpleType" child,
* fail *)
......@@ -295,10 +298,15 @@ let schema_of_uri uri =
and parse_elt_value_constraint (type_def: type_ref) n =
let validate_value v =
lazy (match (!type_def : type_definition) with
| Simple st_def
| Complex { ct_content = CT_simple { contents = Simple st_def } } ->
lazy (match Lazy.force type_def with
| Simple st_def ->
validate_simple_type st_def v
| Complex { ct_content = CT_simple c } ->
(match Lazy.force c with
| Simple st_def ->
validate_simple_type st_def v
| _ ->
validate_simple_type (Primitive (xsd, Utf8.mk "string")) v)
| _ ->
validate_simple_type (Primitive (xsd, Utf8.mk "string")) v
)
......@@ -313,7 +321,7 @@ let schema_of_uri uri =
| None ->
match _may_qname_attr "type" n with
| Some v -> resolve_simple_typ v
| None -> ref (Simple anySimpleType)
| None -> lazy (Simple anySimpleType)
and parse_att_decl global n =
let local = _attr "name" n in
......@@ -388,9 +396,9 @@ let schema_of_uri uri =
| Some v -> (v, `Extension)
| None -> assert false in
let base = resolve_typ (_qname_attr "base" derivation) in
assert(!base != fake_type_def);
let uses = parse_attribute_uses derivation_type !base derivation in
(derivation,derivation_type,!base,uses)
let base = Lazy.force base in
let uses = parse_attribute_uses derivation_type base derivation in
(derivation,derivation_type,base,uses)
and parse_complex_type_def n =
let name = may_name n in
......@@ -404,7 +412,7 @@ let schema_of_uri uri =
in
Complex (complex name base derivation_type uses content_type)
and parse_complex_type n =
ref (parse_complex_type_def n)
lazy (parse_complex_type_def n)
and parse_simple_content n content =
let derivation,derivation_type,base,uses = get_derivation content in
......@@ -415,10 +423,10 @@ let schema_of_uri uri =
match _may_elem "xsd:simpleType" derivation with
| Some s -> parse_simple_type s
| None -> base in
CT_simple (ref (Simple (Derived (None, Restrict, parse_facets base n, base))))
CT_simple (lazy (Simple (Derived (None, Restrict, parse_facets base n, base))))
| `Extension, Complex { ct_content = CT_simple base } ->
CT_simple base
| `Extension, (Simple _ as st) -> CT_simple (ref st)
| `Extension, (Simple _ as st) -> CT_simple (lazy st)
| _ -> assert false
in
base,derivation_type,uses,content_type
......@@ -490,7 +498,7 @@ let schema_of_uri uri =
| None ->
match _may_qname_attr "type" n with
| Some v -> resolve_typ v
| None -> ref AnyType
| None -> lazy AnyType
and parse_particle n =
let min, max = parse_min_max n in
......@@ -501,7 +509,7 @@ let schema_of_uri uri =
| Some ref -> (resolve_elt ref, [ Some ref ])
| None ->
let decl = parse_elt_decl false n in
(ref decl, [ Some (name_of_element_declaration decl) ])
(lazy decl, [ Some (name_of_element_declaration decl) ])
in
(min, max, Elt elt_decl, first)
| "xsd:group" ->
......@@ -553,18 +561,15 @@ let schema_of_uri uri =
let name = get_name n in
if (QTable.mem elts name) then
validation_error ("Redefinition of element " ^ Ns.QName.to_string name);
let r = ref fake_elt_decl in
QTable.add elts name r;
todo := (fun () -> r := parse_elt_decl true n) :: !todo
let l = lazy (parse_elt_decl true n) in
QTable.add elts name l
| ("xsd:simpleType" | "xsd:complexType") as s ->
let name = get_name n in
if (QTable.mem typs name) then
validation_error ("Redefinition of type " ^ Ns.QName.to_string name);
let r = ref fake_type_def in
QTable.add typs name r;
let f = if s="xsd:simpleType" then parse_simple_type_def
else parse_complex_type_def in
todo := (fun () -> r := f n) :: !todo
let l = if s="xsd:simpleType" then lazy (parse_simple_type_def n)
else lazy (parse_complex_type_def n) in
QTable.add typs name l
| "xsd:attribute" ->
let name = get_name n in
QTable.add attr_elems name n;
......
......@@ -42,7 +42,7 @@ type facets = {
and value_ref = Value.t Lazy.t
and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and type_ref = type_definition ref
and type_ref = type_definition Lazy.t
and simple_type_definition =
| Primitive of Ns.qname
......@@ -74,7 +74,7 @@ and attribute_use =
and first = Ns.QName.t option list
and term =
| Elt of element_declaration ref
| Elt of element_declaration Lazy.t
| Model of model_group
and model_group =
......
......@@ -42,7 +42,7 @@ type facets = {
and value_ref = Value.t Lazy.t
and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and type_ref = type_definition ref
and type_ref = type_definition Lazy.t
and simple_type_definition =
| Primitive of Ns.qname
......@@ -74,7 +74,7 @@ and attribute_use =
and first = Ns.QName.t option list
and term =
| Elt of element_declaration ref
| Elt of element_declaration Lazy.t
| Model of model_group
and model_group =
......
......@@ -324,7 +324,7 @@ and validate_type context = function
| Complex ct_def -> validate_complex_type context ct_def
and validate_type_ref context x =
validate_type context !x
validate_type context (Lazy.force x)
(** @return Value.t * Value.t (* attrs, content *) *)
and validate_complex_type context ct =
......@@ -394,7 +394,7 @@ and validate_particle context particle =
(** @return Value.t list *)
and validate_term context term =
match term with
| Elt elt_decl_ref -> [ validate_element context !elt_decl_ref ]
| Elt elt_decl_ref -> [ validate_element context (Lazy.force elt_decl_ref) ]
| Model model_group -> validate_model_group context model_group
(** @return (Value.t list * Utf8.t)
......
......@@ -1578,6 +1578,7 @@ module Schema_converter =
PRegexp (mk_len_regexp ~max:v base)
| _ -> PRegexp base
(* This is not correct ! *)
let mix_regexp =
let pcdata = PStar (PElem (PType Builtin_defs.string)) in
let rec aux = function
......@@ -1594,7 +1595,7 @@ module Schema_converter =
simplify (PSeq (x2, y))
| re -> re
in
fun regexp -> simplify (PSeq (pcdata, aux regexp))
fun regexp -> (*simplify*) (PSeq (pcdata, aux regexp))
(* conversion functions *)
......@@ -1613,17 +1614,19 @@ module Schema_converter =
| Derived (_, _, ({ minInclusive = Some _ } as facets), _)
| Derived (_, _, ({ minExclusive = Some _ } as facets), _) ->
PType (Types.interval (Schema_common.get_interval facets))
| Derived (_, Atomic {contents=Simple (Primitive name)}, facets, _) ->
if is_xsd name "string" || is_xsd name "anyURI" then
(* length *)
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char)) facets
else if is_xsd name "hexBinary" || is_xsd name "base64Binary"
then (* length *)
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char_latin1))
facets
else (* no other interesting facet *)
PType (Schema_builtin.cd_type_of_builtin name)
| Derived (_, Atomic _, facets, _) -> assert false
| Derived (_, Atomic c, facets, _) ->
(match Lazy.force c with
| Simple (Primitive name) ->
if is_xsd name "string" || is_xsd name "anyURI" then
(* length *)
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char)) facets
else if is_xsd name "hexBinary" || is_xsd name "base64Binary"
then (* length *)
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char_latin1))
facets
else (* no other interesting facet *)
PType (Schema_builtin.cd_type_of_builtin name)
| _ -> assert false)
| Derived (_, List item, facets, _) ->
mk_seq_derecurs
~base:(PElem (cd_type_of_simple_type_ref ~schema item)) facets
......@@ -1649,7 +1652,7 @@ module Schema_converter =
let rec regexp_of_term ~schema = function
| Model group -> regexp_of_model_group ~schema group
| Elt decl -> PElem (cd_type_of_elt_decl ~schema !decl)
| Elt decl -> PElem (cd_type_of_elt_decl ~schema (Lazy.force decl))
and regexp_of_model_group ~schema = function
| All [] | Choice [] | Sequence [] -> PEpsilon
......@@ -1694,9 +1697,10 @@ module Schema_converter =
| CT_empty -> PType Sequence.nil_type
| CT_simple st -> cd_type_of_simple_type_ref ~schema st
| CT_model (particle, mixed) ->
if mixed then
Value.failwith' "Mixed content models aren't supported";
(* if mixed then
Value.failwith' "Mixed content models aren't supported"; *)
let regexp = regexp_of_particle ~schema particle in
let regexp = if mixed then mix_regexp regexp else regexp in
PRegexp regexp
in
slot.pdescr <-
......@@ -1736,7 +1740,7 @@ module Schema_converter =
let v = Lazy.force v in
PType (Types.constant (Value.inv_const v))
| _ ->
(match !(elt.elt_typdef) with
(match Lazy.force elt.elt_typdef with
| AnyType ->
PType (Schema_builtin.cd_type_of_builtin (xsd, U.mk "anyType"))
| Simple st ->
......
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