[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

schema/schema_builtin.ml

@@ -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 *)

schema/schema_common.ml

@@ -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

schema/schema_parser.ml

@@ -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;

schema/schema_types.ml

@@ -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 =

schema/schema_types.mli

@@ -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 =

schema/schema_validator.ml

@@ -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)

typing/typer.ml

@@ -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 ->