/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 803 by abate, Tue Jul 10 18:04:14 2007 UTC revision 812 by abate, Tue Jul 10 18:04:55 2007 UTC
# Line 208  Line 208 
208    try    try
209      find_schema_descr k s n      find_schema_descr k s n
210    with Not_found ->    with Not_found ->
211      raise (Error      raise (Error (Printf.sprintf "No %s named '%s' found in schema '%s'"
212        (Printf.sprintf "No %s named '%s' found in schema '%s'"        (Schema_common.string_of_component_kind k) (U.get_str n) (U.get_str s)))
         (Schema_common.string_of_component_kind k) n s))  
213    
214  (* Eliminate Recursion, propagate Sequence Capture Variables *)  (* Eliminate Recursion, propagate Sequence Capture Variables *)
215    
# Line 765  Line 764 
764                  | _ -> ()) env.ids                  | _ -> ()) env.ids
765  let dump_type ppf env name =  let dump_type ppf env name =
766    try    try
767      (match Env.find (Ident.ident (Encodings.Utf8.mk name)) env.ids with      (match Env.find (Ident.ident name) env.ids with
768      | Type t -> Types.Print.print ppf t      | Type t -> Types.Print.print ppf t
769      | _ -> raise Not_found)      | _ -> raise Not_found)
770    with Not_found -> raise (Error (Printf.sprintf "Type %s not found" name))    with Not_found ->
771        raise (Error (Printf.sprintf "Type %s not found" (U.get_str name)))
772    
773  let dump_schema_type ppf (k, s, n) =  let dump_schema_type ppf (k, s, n) =
774    let descr = find_schema_descr' k s n in    let descr = find_schema_descr' k s n in
# Line 1359  Line 1359 
1359            PRegexp (mk_len_regexp ~max:v base, nil_type)            PRegexp (mk_len_regexp ~max:v base, nil_type)
1360        | _ -> PRegexp (base, nil_type)        | _ -> PRegexp (base, nil_type)
1361    
1362        let mix_regexp =
1363          let pcdata = PStar (PElem (PType Builtin_defs.string)) in
1364          let rec aux = function
1365            | PEpsilon -> PEpsilon
1366            | PElem re -> PElem re
1367            | PSeq (re1, re2) -> PSeq (aux re1, PSeq (pcdata, aux re2))
1368            | PAlt (re1, re2) -> PAlt (aux re1, aux re2)
1369            | PStar re -> PStar (aux re)
1370            | PWeakStar re -> PWeakStar (aux re)
1371          in
1372          let rec simplify = function
1373            | PSeq (x1, PSeq (x2, y)) when x1 = pcdata && x2 = pcdata ->
1374                simplify (PSeq (x2, y))
1375            | re -> re
1376          in
1377          fun regexp -> simplify (PSeq (pcdata, aux regexp))
1378    
1379      (* conversion functions *)      (* conversion functions *)
1380    
1381      let rec cd_type_of_simple_type ~schema = function      let rec cd_type_of_simple_type ~schema = function
# Line 1375  Line 1392 
1392        | Derived (_, _, ({ minInclusive = Some _ } as facets), _)        | Derived (_, _, ({ minInclusive = Some _ } as facets), _)
1393        | Derived (_, _, ({ minExclusive = Some _ } as facets), _) ->        | Derived (_, _, ({ minExclusive = Some _ } as facets), _) ->
1394            PType (Types.interval (Schema_common.get_interval facets))            PType (Types.interval (Schema_common.get_interval facets))
1395        | Derived (_, Atomic (Primitive "xsd:string"), facets, _) (* length *)        | Derived (_, Atomic (Primitive name), facets, _) ->
1396        | Derived (_, Atomic (Primitive "xsd:anyURI"), facets, _) ->            if name = U.mk "xsd:string" || name = U.mk "xsd:anyURI" then
1397                (* length *)
1398            mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char)) facets            mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char)) facets
1399        | Derived (_, Atomic (Primitive "xsd:hexBinary"), facets, _)            else if name = U.mk "xsd:hexBinary" ||
1400        | Derived (_, Atomic (Primitive "xsd:base64Binary"), facets, _) ->              name = U.mk "xsd:base64Binary"
1401            mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char_latin1)) facets            then (* length *)
1402        | Derived (_, Atomic (Primitive name), _, _) ->              mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char_latin1))
1403            (* no other interesting facet *)                facets
1404              else (* no other interesting facet *)
1405            PType (Schema_builtin.cd_type_of_builtin name)            PType (Schema_builtin.cd_type_of_builtin name)
1406        | Derived (_, Atomic _, facets, _) -> assert false        | Derived (_, Atomic _, facets, _) -> assert false
1407        | Derived (_, List item, facets, _) ->        | Derived (_, List item, facets, _) ->
# Line 1418  Line 1437 
1437        | CT_empty -> PEpsilon        | CT_empty -> PEpsilon
1438        | CT_simple st -> PElem (cd_type_of_simple_type ~schema st)        | CT_simple st -> PElem (cd_type_of_simple_type ~schema st)
1439        | CT_model (particle, mixed) ->        | CT_model (particle, mixed) ->
1440            assert (not mixed); (* TODO mixed support *)            let regexp = regexp_of_particle ~schema particle in
1441            regexp_of_particle ~schema particle            if mixed then begin (* TODO mixed *)
1442                Value.failwith' "Mixed content models aren't supported";
1443                mix_regexp regexp
1444              end else
1445                regexp
1446    
1447      and regexp_of_particle ~schema (min, max, term) =      and regexp_of_particle ~schema (min, max, term) =
1448        mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term)        mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term)
# Line 1449  Line 1472 
1472                | _ -> cd_type_of_simple_type ~schema st                | _ -> cd_type_of_simple_type ~schema st
1473              in              in
1474              let r = if required then r else POptional r in              let r = if required then r else POptional r in
1475              (LabelPool.mk (schema.targetNamespace, U.mk name), r))              (LabelPool.mk (schema.targetNamespace, name), r))
1476            attr_uses in            attr_uses in
1477        PRecord (false, LabelMap.from_list_disj fields)        PRecord (false, LabelMap.from_list_disj fields)
1478    
# Line 1457  Line 1480 
1480        let r = cd_type_of_simple_type ~schema st in        let r = cd_type_of_simple_type ~schema st in
1481        PRecord (false,        PRecord (false,
1482          LabelMap.from_list_disj          LabelMap.from_list_disj
1483            [(LabelPool.mk (schema.targetNamespace, U.mk name), r)])            [(LabelPool.mk (schema.targetNamespace, name), r)])
1484    
1485      and cd_type_of_elt_decl ~schema (_, name, typ, constr) =      and cd_type_of_elt_decl ~schema (_, name, typ, constr) =
1486        let atom_type =        let atom_type =
1487          PType (Types.atom (Atoms.atom (Atoms.V.mk schema.targetNamespace          PType (Types.atom (Atoms.atom (Atoms.V.mk schema.targetNamespace name)))
           (U.mk name))))  
1488        in        in
1489        let content =        let content =
1490          match constr with          match constr with
1491          | Some (`Fixed v) -> PType (Types.constant (Value.inv_const v))          | Some (`Fixed v) -> PType (Types.constant (Value.inv_const v))
1492          | _ ->          | _ ->
1493            (match !typ with            (match !typ with
1494            | AnyType -> PType (Schema_builtin.cd_type_of_builtin "xsd:anyType")            | AnyType ->
1495                  PType (Schema_builtin.cd_type_of_builtin (U.mk "xsd:anyType"))
1496            | Simple st ->            | Simple st ->
1497                PTimes                PTimes
1498                  (PType Types.empty_closed_record,                  (PType Types.empty_closed_record,
# Line 1490  Line 1513 
1513         * Shadows previous definitions.         * Shadows previous definitions.
1514         *)         *)
1515      let cd_type_of_type_def ~schema = function      let cd_type_of_type_def ~schema = function
1516        | AnyType -> Schema_builtin.cd_type_of_builtin "xsd:anyType"        | AnyType -> Schema_builtin.cd_type_of_builtin (U.mk "xsd:anyType")
1517        | Simple st -> typ (cd_type_of_simple_type ~schema st)        | Simple st -> typ (cd_type_of_simple_type ~schema st)
1518        | Complex ct -> typ (cd_type_of_complex_type ~schema ct)        | Complex ct -> typ (cd_type_of_complex_type ~schema ct)
1519      let cd_type_of_elt_decl ~schema x = typ (cd_type_of_elt_decl ~schema x)      let cd_type_of_elt_decl ~schema x = typ (cd_type_of_elt_decl ~schema x)
# Line 1504  Line 1527 
1527  let get_schema name =  let get_schema name =
1528    try    try
1529      Hashtbl.find !schemas name      Hashtbl.find !schemas name
1530    with Not_found -> raise (Error (Printf.sprintf "Schema '%s' not found" name))    with Not_found ->
1531        raise (Error (Printf.sprintf "Schema '%s' not found" (U.get_str name)))
1532    
1533  let get_schema_names () = Hashtbl.fold (fun n _ acc -> n :: acc) !schemas []  let get_schema_names () = Hashtbl.fold (fun n _ acc -> n :: acc) !schemas []
1534    
1535  let register_schema schema_name schema =  let register_schema schema_name schema =
1536    if Hashtbl.mem !schemas schema_name then    if Hashtbl.mem !schemas schema_name then
1537      failwith ("Redefinition of schema " ^ schema_name)      failwith ("Redefinition of schema " ^ U.get_str schema_name)
1538    else begin    else begin
1539      let log_schema_component kind schema name cd_type =      let log_schema_component kind schema name cd_type =
1540        if not (Schema_builtin.is_builtin name) then begin        if not (Schema_builtin.is_builtin name) then begin
1541          Format.fprintf Format.std_formatter          Format.fprintf Format.std_formatter
1542            "Registering schema %s: %s # %s" kind schema name;            "Registering schema %s: %s # %s"
1543                kind (U.get_str schema) (U.get_str name);
1544          if debug_schema then          if debug_schema then
1545            Types.Print.print Format.std_formatter cd_type;            Types.Print.print Format.std_formatter cd_type;
1546          Format.fprintf Format.std_formatter "@."          Format.fprintf Format.std_formatter "@."
Legend:
Removed from v.803  
changed lines
  Added in v.812
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5