Commit b56b9467 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-04-22 13:18:00 by afrisch] Factor-out internalization of types/patterns

Original author: afrisch
Date: 2005-04-22 13:18:01+00:00
parent 6f133b9d
......@@ -161,7 +161,7 @@ OBJECTS = \
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\
types/externals.cmo \
typing/typed.cmo typing/typer.cmo \
typing/typed.cmo typing/typepat.cmo typing/typer.cmo \
\
$(SCHEMA_OBJS) \
\
......
......@@ -114,14 +114,20 @@ typing/typed.cmo: types/types.cmi types/patterns.cmi misc/ns.cmi \
parser/location.cmi types/ident.cmo
typing/typed.cmx: types/types.cmx types/patterns.cmx misc/ns.cmx \
parser/location.cmx types/ident.cmx
typing/typer.cmo: types/types.cmi typing/typed.cmo misc/serialize.cmi \
types/sequence.cmi types/patterns.cmi misc/ns.cmi parser/location.cmi \
types/ident.cmo misc/html.cmi types/externals.cmi types/chars.cmi \
types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo typing/typer.cmi
typing/typer.cmx: types/types.cmx typing/typed.cmx misc/serialize.cmx \
types/sequence.cmx types/patterns.cmx misc/ns.cmx parser/location.cmx \
types/ident.cmx misc/html.cmx types/externals.cmx types/chars.cmx \
types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx typing/typer.cmi
typing/typepat.cmo: types/types.cmi types/sequence.cmi types/patterns.cmi \
parser/location.cmi types/ident.cmo types/chars.cmi typing/typepat.cmi
typing/typepat.cmx: types/types.cmx types/sequence.cmx types/patterns.cmx \
parser/location.cmx types/ident.cmx types/chars.cmx typing/typepat.cmi
typing/typer.cmo: types/types.cmi typing/typepat.cmi typing/typed.cmo \
misc/serialize.cmi types/sequence.cmi types/patterns.cmi misc/ns.cmi \
parser/location.cmi types/ident.cmo misc/html.cmi types/externals.cmi \
types/chars.cmi types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
typing/typer.cmi
typing/typer.cmx: types/types.cmx typing/typepat.cmx typing/typed.cmx \
misc/serialize.cmx types/sequence.cmx types/patterns.cmx misc/ns.cmx \
parser/location.cmx types/ident.cmx misc/html.cmx types/externals.cmx \
types/chars.cmx types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
typing/typer.cmi
schema/schema_pcre.cmo: misc/encodings.cmi schema/schema_pcre.cmi
schema/schema_pcre.cmx: misc/encodings.cmx schema/schema_pcre.cmi
schema/schema_types.cmo: runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
......@@ -278,10 +284,8 @@ ocamliface/mlstub.cmx: types/types.cmx typing/typer.cmx types/sequence.cmx \
driver/librarian.cmx types/ident.cmx types/externals.cmx \
driver/config.cmx compile/compile.cmx types/builtin_defs.cmx \
types/atoms.cmx ocamliface/mlstub.cmi
parser/cduce_netclient.cmo: parser/url.cmi parser/location.cmi \
driver/config.cmi
parser/cduce_netclient.cmx: parser/url.cmx parser/location.cmx \
driver/config.cmx
parser/cduce_curl.cmo: parser/url.cmi driver/config.cmi
parser/cduce_curl.cmx: parser/url.cmx driver/config.cmx
runtime/cduce_pxp.cmo: parser/url.cmi schema/schema_xml.cmi \
parser/location.cmi runtime/load_xml.cmi driver/config.cmi \
runtime/cduce_pxp.cmi
......
......@@ -3,34 +3,33 @@ open Schema_types
open Schema_common
open Schema_validator
open Encodings
open Typer.IType
open Typepat
let xsd = Schema_xml.xsd
let is_xsd (ns,l) local =
(Ns.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)
let complex_memo = Hashtbl.create 213
let rexp re = rexp (simplify_regexp re)
(* TODO: better approx *)
let xsd_any_type = Types.any
let nil_type = itype Sequence.nil_type
let nil_type = mk_type Sequence.nil_type
let mk_len_regexp min max base =
let rec repeat_regexp re = function
| 0 -> eps
| n -> seq re (repeat_regexp re (pred n))
| 0 -> mk_epsilon
| n -> mk_seq re (repeat_regexp re (pred n))
in
let min_regexp = repeat_regexp base min in
match max with
| Some max ->
let rec aux acc = function
| 0 -> acc
| n -> aux (alt eps (seq base acc)) (pred n)
| n -> aux (mk_alt mk_epsilon (mk_seq base acc)) (pred n)
in
seq min_regexp (aux eps (max-min))
| None -> seq min_regexp (star base)
mk_seq min_regexp (aux mk_epsilon (max-min))
| None -> mk_seq min_regexp (mk_star base)
let mk_seq_derecurs base facets =
let min,max = match facets with
......@@ -76,21 +75,21 @@ let attr_uses (attrs,other) =
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> elem (elt_decl decl)
| Wildcard w -> elem (wildcard w)
| Elt decl -> mk_elem (elt_decl decl)
| Wildcard w -> mk_elem (wildcard w)
and wildcard w =
itype (Builtin_defs.any_xml_with_tag w.wild_first)
mk_type (Builtin_defs.any_xml_with_tag w.wild_first)
and regexp_of_model_group = function
| Choice l ->
List.fold_left
(fun acc particle -> alt acc (regexp_of_particle particle))
emp l
(fun acc particle -> mk_alt acc (regexp_of_particle particle))
mk_empty l
| All l | Sequence l ->
List.fold_left
(fun acc particle -> seq acc (regexp_of_particle particle))
eps l
(fun acc particle -> mk_seq acc (regexp_of_particle particle))
mk_epsilon l
and regexp_of_particle p =
mk_len_regexp p.part_min p.part_max (regexp_of_term p.part_term)
......@@ -98,9 +97,9 @@ and regexp_of_particle p =
and get_complex ct =
try Hashtbl.find complex_memo ct.ct_uid
with Not_found ->
let slot = delayed () in
let slot = mk_delayed () in
let attrs = attr_uses ct.ct_attrs in
let r = times (itype attrs) slot in
let r = mk_prod (mk_type attrs) slot in
Hashtbl.add complex_memo ct.ct_uid r;
link slot (content ct.ct_content);
r
......@@ -110,35 +109,35 @@ and complex nil ct =
if nil then
let (attrs,content) = get_ct c in
let attrs = Types.Record.merge attrs xsi_nil_type in
ior c (itype (Types.times (Types.cons attrs) Sequence.nil_node))
mk_or c (mk_type (Types.times (Types.cons attrs) Sequence.nil_node))
else c
and content = function
| CT_empty -> itype Sequence.nil_type
| CT_simple st -> itype (simple_type st)
| CT_empty -> mk_type Sequence.nil_type
| CT_simple st -> mk_type (simple_type st)
| CT_model (particle, mixed) ->
let regexp = regexp_of_particle particle in
rexp (if mixed then mix regexp else regexp)
rexp_simplify ~mix:mixed regexp
and elt_decl elt =
let atom_type =
itype (Types.atom (Atoms.atom (Atoms.V.of_qname elt.elt_name)))
mk_type (Types.atom (Atoms.atom (Atoms.V.of_qname elt.elt_name)))
in
let content=complex_type_def elt.elt_nillable (Lazy.force elt.elt_typdef) in
let content =
match elt.elt_cstr with
| Some (`Fixed (_,v)) ->
iand content (
itype (Types.times
mk_and content (
mk_type (Types.times
(Types.cons Types.any)
(Types.cons (Types.constant (Value.inv_const v)))))
| _ -> content in
xml atom_type content
mk_xml atom_type content
and complex_type_def nil = function
| AnyType ->
itype (Types.times
mk_type (Types.times
(Types.cons Types.empty_open_record)
(Types.cons xsd_any_type))
| Simple st ->
......@@ -154,15 +153,17 @@ and complex_type_def nil = function
(Types.cons xsi_nil_type)
(Types.cons Sequence.nil_type))
else nonnil in
itype t
mk_type t
| Complex ct -> complex nil ct
let model_group g = rexp (regexp_of_model_group g)
let model_group g = rexp_simplify ~mix:false (regexp_of_model_group g)
let get_type d = internalize d; typ d
let type_def = function
| AnyType -> xsd_any_type
| Simple st -> simple_type st
| Complex ct -> get_type (xml (itype Types.any) (complex false ct))
| Complex ct -> get_type (mk_xml (mk_type Types.any) (complex false ct))
let elt_decl x = get_type (elt_decl x)
let model_group x = get_type (model_group x.mg_def)
let attr_group ag = attr_uses ag.ag_def
......
This diff is collapsed.
open Ident
type node
val mk_delayed: unit -> node
val link: node -> node -> unit
val mk_type : Types.descr -> node
val mk_or : node -> node -> node
val mk_and: node -> node -> node
val mk_diff: node -> node -> node
val mk_prod: node -> node -> node
val mk_xml: node -> node -> node
val mk_arrow: node -> node -> node
val mk_optional: node -> node
val mk_record: bool -> (node * node option) label_map -> node
val mk_constant: id -> Types.const -> node
val mk_capture: id -> node
val mk_concat: node -> node -> node
val mk_merge: node -> node -> node
val check_wf: node -> bool
val elim_concats: unit -> unit
val internalize: node -> unit
val peek_fv: node -> id option
val typ : node -> Types.descr
val typ_node : node -> Types.Node.t
val pat_node : node -> Patterns.node
val get_ct: node -> Types.t * node
type re
val mk_empty: re
val mk_epsilon: re
val mk_elem: node -> re
val mk_guard: node -> re
val mk_seq: re -> re -> re
val mk_alt: re -> re -> re
val mk_star: re -> re
val mk_weakstar: re -> re
val mk_seqcapt: id -> re -> re
val rexp: re -> node
val rexp_simplify: mix:bool -> re -> node
This diff is collapsed.
......@@ -62,40 +62,6 @@ type type_fun = Types.t -> bool -> Types.t
val register_op: string -> int -> (type_fun list -> type_fun) -> unit
val flatten: type_fun -> type_fun
module IType : sig
type node
val get_type: node -> Types.t
val itype: Types.t -> node
val delayed: unit -> node
val link: node -> node -> unit
val ior: node -> node -> node
val iand: node -> node -> node
val times: node -> node -> node
val record: bool -> (node * node option) Ident.label_map -> node
val xml: node -> node -> node
val optional: node -> node
val get_ct: node -> Types.t * node
(* Regular expression *)
type regexp
val rexp: regexp -> node
val simplify_regexp: regexp -> regexp
val eps: regexp
val emp: regexp
val seq: regexp -> regexp -> regexp
val alt: regexp -> regexp -> regexp
val star: regexp -> regexp
val mix: regexp -> regexp
val elem: node -> regexp
end
(* Forward definitions *)
val from_comp_unit: (Types.CompUnit.t -> t) ref
val has_comp_unit: (U.t -> bool) ref
......
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