[r2005-02-22 15:33:36 by afrisch] Clean

Original author: afrisch
Date: 2005-02-22 15:33:36+00:00

schema/schema_common.ml

@@ -103,7 +103,7 @@ 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 (Lazy.force elt_decl_ref)
+  | { part_term = Elt e } ->  name_of_element_declaration (Lazy.force e)
   | _ -> assert false
 let variety_of_simple_type_definition = function
   | (Primitive name) as st -> Atomic (lazy (Simple st))
@@ -146,8 +146,9 @@ let rec normalize_white_space =
 let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
 let anyType = AnyType
 
-let first_of_particle (_, _, _, first) = first
-let nullable p = List.mem None (first_of_particle p)
+let first_of_particle p = p.part_first
+let nullable p = p.part_nullable
+
 let first_of_model_group = function
   | All particles | Choice particles ->
       List.concat (List.map first_of_particle particles)
@@ -158,10 +159,11 @@ let first_of_model_group = function
         | [] -> []
       in
       aux particles
-let rec is_in_first tag = function
-  | [] -> false
-  | Some tag' :: rest when Ns.QName.equal tag' tag -> true
-  | _ :: rest -> is_in_first tag rest
+
+let nullable_of_model_group = function
+  | All particles | Sequence particles -> List.for_all nullable particles
+  | Choice particles -> List.exists nullable particles
+
 
 let get_interval facets =
   (* ASSUMPTION:
@@ -430,8 +432,8 @@ 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_particle ppf p =
+  print_term ppf p.part_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

schema/schema_common.mli

@@ -61,10 +61,10 @@ val iter_attribute_groups:
   schema -> (attribute_group_definition -> unit) -> unit
 val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
 
-val first_of_particle: particle -> first
-val first_of_model_group: model_group -> first
-val is_in_first: Ns.qname -> first -> bool
+val first_of_particle: particle -> Ns.qname list
 val nullable: particle -> bool
+val first_of_model_group: model_group -> Ns.qname list
+val nullable_of_model_group: model_group -> bool
 
 (** {2 Facets} *)
 

schema/schema_parser.ml

@@ -11,6 +11,20 @@ module QTable = Hashtbl.Make(Ns.QName)
 
 let validation_error s = raise (XSD_validation_error s)
 
+let particle min max term first nullable =
+  { part_min = min;
+    part_max = max;
+    part_term = term;
+    part_first = first;
+    part_nullable = nullable }
+
+let particle_model min max mg =
+  particle min max 
+    (Model mg)
+    (first_of_model_group mg)
+    (nullable_of_model_group mg)
+
+
 let xsd = Schema_xml.xsd
 
 (*
@@ -65,23 +79,23 @@ let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
 let parse_facets base n =
   let validate_base_type v = 
     lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in 
-  let validate_nonNegativeInteger =
-    Schema_builtin.validate_builtin (xsd, Utf8.mk "nonNegativeInteger")
+  let parse_nonneg n =
+    let s = Utf8.get_str (_attr "value" n) in
+    let i = int_of_string s in
+    if (i < 0) then failwith "Unexpected negative integer";
+    i
   in
   let aux facets n tag =
     let fixed = _is_attr "fixed" n "true" in
     match tag with
       | "xsd:length" ->
-          let value = _attr "value" n in
-          let length = Value.get_integer (validate_nonNegativeInteger value) in
+          let length = parse_nonneg n in
           { facets with length = Some (length, fixed) }
       | "xsd:minLength" ->
-          let value = _attr "value" n in
-          let length = Value.get_integer (validate_nonNegativeInteger value) in
+          let length = parse_nonneg n in
           { facets with minLength = Some (length, fixed) }
       | "xsd:maxLength" ->
-          let value = _attr "value" n in
-          let length = Value.get_integer (validate_nonNegativeInteger value) in
+          let length = parse_nonneg n in
           { facets with maxLength = Some (length, fixed) }
       | "xsd:enumeration" ->
           let value = Value.string_utf8 (_attr "value" n) in
@@ -134,12 +148,14 @@ let parse_att_value_constraint stype_def n =
 
 let parse_min_max n =
   (match _may_attr "minOccurs" n with 
-     | Some v -> Intervals.V.mk (Utf8.get_str v)
-     | None -> Intervals.V.one),
+     | Some v -> int_of_string (Utf8.get_str v)
+     | None -> 1),
   (match _may_attr "maxOccurs" n with 
-     | Some v when Utf8.get_str v = "unbounded" -> None
-     | Some v -> Some (Intervals.V.mk (Utf8.get_str v))
-     | None -> Some Intervals.V.one)
+     | Some v ->
+	 (match Utf8.get_str v with 
+	    | "unbounded" -> None 
+	    | v -> Some (int_of_string v))
+     | None -> Some 1)
 
 let rec first n f = function
   | [] -> None
@@ -453,10 +469,7 @@ let schema_of_uri uri =
 		  CT_model (particle, mixed)
 	      | CT_model (p, _) ->
 		  let model = Sequence (p::[particle]) in
-		  CT_model
-		    ((Intervals.V.one, Some (Intervals.V.one), Model model,
-		      first_of_model_group model),
-		     mixed)
+		  CT_model (particle_model 1 (Some 1) model, mixed)
 	      | CT_simple _ -> assert false
     in
     base,derivation_type,uses,content_type
@@ -502,22 +515,18 @@ let schema_of_uri uri =
 		      
   and parse_particle n =
     let min, max = parse_min_max n in
+    let model mg = particle_model min max mg in
+    let elt e n = particle min max (Elt e) [ n ] false in
     match _tag n with
       | "xsd:element" ->
-	  let elt_decl, first =
-	    match _may_qname_attr "ref" n with
-	      | Some ref -> (resolve_elt ref, [ Some ref ])
-	      | None ->
-		  let decl = parse_elt_decl false n in
-		  (lazy decl, [ Some (name_of_element_declaration decl) ])
-	  in
-	  (min, max, Elt elt_decl, first)
-      | "xsd:group" ->
-	  let mg = resolve_model_group (_qname_attr "ref" n) in
-	  (min, max, Model mg.mg_def, first_of_model_group mg.mg_def)
-      | "xsd:all" | "xsd:sequence" | "xsd:choice" ->
-	  let model_group = parse_model_group n in
-	  (min, max, Model model_group, first_of_model_group model_group)
+	  (match _may_qname_attr "ref" n with
+	     | Some ref -> elt (resolve_elt ref) ref
+	     | None ->
+		 let decl = parse_elt_decl false n in
+		 elt (lazy decl) (name_of_element_declaration decl))
+      | "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
+      | "xsd:all" | "xsd:sequence" | "xsd:choice" -> 
+	  model (parse_model_group n)
       | _ -> assert false
 	  
   and parse_model_group n =

schema/schema_types.ml

@@ -16,16 +16,13 @@ open Encodings
 
 (** {2 XSD representation} *)
 
-type xs_nonNegativeInteger = Intervals.V.t  (* = Big_int.big_int *)
-(* type xs_positiveInteger = Intervals.V.t *)
-
 type derivation_type = [ `Extension | `Restriction ]
 type white_space_handling = [ `Preserve | `Replace | `Collapse ]
 
 type facets = {
-  length: (xs_nonNegativeInteger * bool) option;      (* length, fixed *)
-  minLength: (xs_nonNegativeInteger * bool) option;   (* length, fixed *)
-  maxLength: (xs_nonNegativeInteger * bool) option;   (* length, fixed *)
+  length: (int * bool) option;      (* length, fixed *)
+  minLength: (int * bool) option;   (* length, fixed *)
+  maxLength: (int * bool) option;   (* length, fixed *)
 (*   pattern: Schema_regexp.regexp list;           (* list of ANDed patterns *) *)
   enumeration: value_ref list option;
   whiteSpace: white_space_handling * bool;           (* handling, fixed *)
@@ -69,10 +66,6 @@ and attribute_use =
       attr_decl : attribute_declaration;
       attr_use_cstr : value_constraint option }
 
-(* first construction as per predictive parsing. None stands for epsilon, Some
- * Utf8.t stands for a start tag of identical name *)
-and first = Ns.QName.t option list
-
 and term =
   | Elt of element_declaration Lazy.t
   | Model of model_group
@@ -85,15 +78,14 @@ and model_group =
 and content_type =
   | CT_empty
   | CT_simple of type_ref
-  | CT_model of
-      particle *
-      bool        (* mixed *)
+  | CT_model of particle * bool        (* mixed *)
 
 and particle =
-  xs_nonNegativeInteger *           (* minOccurs *)
-  xs_nonNegativeInteger option *    (* maxOccurs (None = "unbounded") *)
-  term *
-  first
+    { part_min: int;
+      part_max: int option;  (* None = unbounded *)
+      part_term: term;
+      part_first: Ns.qname list;
+      part_nullable: bool }
 
 and element_declaration =
     { elt_uid: int;

schema/schema_types.mli

@@ -16,16 +16,13 @@ open Encodings
 
 (** {2 XSD representation} *)
 
-type xs_nonNegativeInteger = Intervals.V.t  (* = Big_int.big_int *)
-(* type xs_positiveInteger = Intervals.V.t *)
-
 type derivation_type = [ `Extension | `Restriction ]
 type white_space_handling = [ `Preserve | `Replace | `Collapse ]
 
 type facets = {
-  length: (xs_nonNegativeInteger * bool) option;      (* length, fixed *)
-  minLength: (xs_nonNegativeInteger * bool) option;   (* length, fixed *)
-  maxLength: (xs_nonNegativeInteger * bool) option;   (* length, fixed *)
+  length: (int * bool) option;      (* length, fixed *)
+  minLength: (int * bool) option;   (* length, fixed *)
+  maxLength: (int * bool) option;   (* length, fixed *)
 (*   pattern: Schema_regexp.regexp list;           (* list of ANDed patterns *) *)
   enumeration: value_ref list option;
   whiteSpace: white_space_handling * bool;           (* handling, fixed *)
@@ -69,10 +66,6 @@ and attribute_use =
       attr_decl : attribute_declaration;
       attr_use_cstr : value_constraint option }
 
-(* first construction as per predictive parsing. None stands for epsilon, Some
- * Utf8.t stands for a start tag of identical name *)
-and first = Ns.QName.t option list
-
 and term =
   | Elt of element_declaration Lazy.t
   | Model of model_group
@@ -85,15 +78,14 @@ and model_group =
 and content_type =
   | CT_empty
   | CT_simple of type_ref
-  | CT_model of
-      particle *
-      bool        (* mixed *)
+  | CT_model of particle * bool        (* mixed *)
 
 and particle =
-  xs_nonNegativeInteger *           (* minOccurs *)
-  xs_nonNegativeInteger option *    (* maxOccurs (None = "unbounded") *)
-  term *
-  first
+    { part_min: int;
+      part_max: int option;  (* None = unbounded *)
+      part_term: term;
+      part_first: Ns.qname list;
+      part_nullable: bool }
 
 and element_declaration =
     { elt_uid: int;

schema/schema_validator.ml

@@ -33,10 +33,8 @@ let ptbl_of_particles particles =
   let tbl = QTable.create 20 in
   List.iter (* fill table *)
     (* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
-    (fun p ->
-      List.iter
-        (function None -> () | Some tag -> QTable.add tbl tag p)
-        (first_of_particle p))
+    (fun p -> 
+       List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
     particles;
   tbl
 
@@ -54,10 +52,6 @@ class type validation_context =
 
     method set_mixed: bool -> unit
     method mixed: bool
-
-(*
-    method ns: Ns.t
-*)
   end
 
 let validation_error ?context s = raise (XSI_validation_error s)
@@ -103,21 +97,20 @@ struct
      * and no Concat, but just Pair *)
   let length v =
     let rec aux acc = function
-      | Pair (_, rest) -> aux (Intervals.V.succ acc) rest
-      | v when v = Value.nil -> Intervals.V.zero
-      | _ -> assert false
+      | Pair (_, rest) -> aux (succ acc) rest
+      | _ -> 0
     in
-    aux Intervals.V.zero v
+    aux 0 v
 
   let length_valid len value =
-    if not (Intervals.V.equal (length value) len) then
-      raise (Facet_error "length")
+    if (length value != len) 
+    then raise (Facet_error "length")
   let minLength_valid min_len value =
-    if Intervals.V.lt (length value) min_len then
-      raise (Facet_error "minLength")
+    if (length value < min_len)
+    then raise (Facet_error "minLength")
   let maxLength_valid max_len value =
-    if Intervals.V.gt (length value) max_len then
-      raise (Facet_error "maxLength")
+    if (length value > max_len) 
+    then raise (Facet_error "maxLength")
 
   let enumeration_valid enum value =
     if not (List.exists (fun x -> Value.equal value (Lazy.force x)) enum) 
@@ -341,13 +334,13 @@ and validate_content_type context content_type : Value.t =
       validate_particle context particle
 
 and validate_particle context particle =
-  let (min, max, term, first) = particle in
   let content = ref Value.nil in
   let concat v = content := Value.concat !content v in
   let rec validate_once ~cont_ok ~cont_failure =
     match context#peek with
-    | E_start_tag qname when is_in_first qname first ->
-	concat (validate_term context term);
+    | E_start_tag qname 
+	when List.exists (Ns.QName.equal qname) particle.part_first ->
+	concat (validate_term context particle.part_term);
         cont_ok ()
     | E_char_data utf8_data when context#mixed ->
         concat (string_utf8 utf8_data);
@@ -356,10 +349,10 @@ and validate_particle context particle =
     | ev -> cont_failure ev
   in
   let rec required = function
-    | v when Intervals.V.equal v Intervals.V.zero -> ()
-    | n (* when n > 0 *) ->
+    | 0 -> ()
+    | n ->
         validate_once
-          ~cont_ok:(fun () -> required (Intervals.V.pred n))
+          ~cont_ok:(fun () -> required (pred n))
           ~cont_failure:(fun event ->
             validation_error ~context (sprintf "Unexpected content: %s"
               (string_of_event event)))
@@ -369,10 +362,10 @@ and validate_particle context particle =
         validate_once
           ~cont_ok:(fun () -> optional None)
           ~cont_failure:(fun _ -> ())
-    | Some v when Intervals.V.equal v Intervals.V.zero -> ()
-    | Some n (* when n > 0 *) ->
+    | Some 0 -> ()
+    | Some n ->
         validate_once
-          ~cont_ok:(fun () -> optional (Some (Intervals.V.pred n)))
+          ~cont_ok:(fun () -> optional (Some (pred n)))
           ~cont_failure:(fun _ -> ())
   in
   let rec trailing_cdata () =
@@ -383,9 +376,11 @@ and validate_particle context particle =
         trailing_cdata ()
     | _ -> ()
   in
-  required min;
+  required particle.part_min;
   optional
-    (match max with None -> None | Some v -> Some (Intervals.V.sub v min));
+    (match particle.part_max with 
+       | None -> None 
+       | Some v -> Some (v - particle.part_min));
   if context#mixed then trailing_cdata ();
   !content
 
@@ -518,10 +513,6 @@ class context ~stream ~schema =
             (string_of_event ev));
           foo_qname (* useless *)
 
-(*
-    method ns = schema.targetNamespace
-*)
-
   end
 
   (** {2 API} *)

typing/typer.ml

@@ -1508,22 +1508,19 @@ module Schema_converter =
 
     let mk_len_regexp ?min ?max base =
       let rec repeat_regexp re = function
-        | z when Intervals.V.is_zero z -> PEpsilon
-        | n when Intervals.V.gt n Intervals.V.zero ->
-            seq re (repeat_regexp re (Intervals.V.pred n))
-        | _ -> assert false
+        | 0 -> PEpsilon
+        | n -> seq re (repeat_regexp re (pred n))
       in
-      let min = match min with Some min -> min | _ -> Intervals.V.one in
+      let min = match min with Some min -> min | _ -> 1 in
       let min_regexp = repeat_regexp base min in
       match max with
       | Some max ->
 	  (*  assert (max >= min);   Need to use Bigint comparison ! -- AF *)
 	  let rec aux acc = function
-            | z when Intervals.V.is_zero z -> acc
-            | n ->
-                aux (PAlt (PEpsilon, (seq base acc))) (Intervals.V.pred n)
+            | 0 -> acc
+            | n -> aux (PAlt (PEpsilon, (seq base acc))) (pred n)
           in
-          seq min_regexp (aux PEpsilon (Intervals.V.sub max min))
+          seq min_regexp (aux PEpsilon (max-min))
       | None -> seq min_regexp  (PStar base)
 
       (* given a base derecurs create a derecurs value representing a sequence
@@ -1621,8 +1618,9 @@ module Schema_converter =
               seq acc (regexp_of_particle ~schema particle))
             (regexp_of_particle ~schema hd) tl
 
-    and regexp_of_particle ~schema (min, max, term, _) =
-      mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term)
+    and regexp_of_particle ~schema p =
+      mk_len_regexp ?min:(Some p.part_min) ?max:p.part_max 
+	(regexp_of_term ~schema p.part_term)
 
       (** @return a pair composed by a type for the attributes (a record) and a
       type for the content model (a sequence) *)