Skip to content

GitLab

Commit 4b4c0821 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-07-02 23:26:38 by afrisch] Serialize schema by reference 

Original author: afrisch
Date: 2004-07-02 23:26:39+00:00
parent 1e3a9cba
Hide whitespace changes
Inline Side-by-side
Showing with 248 additions and 135 deletions
Makefile.distrib
View file @ 4b4c0821
......@@ -134,6 +134,14 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests
# Objects to build
SCHEMA_OBJS = \
schema/schema_types.cmo \
schema/schema_xml.cmo \
schema/schema_common.cmo \
schema/schema_builtin.cmo \
schema/schema_validator.cmo \
schema/schema_parser.cmo \
OBJECTS = \
driver/config.cmo \
misc/stats.cmo \
......@@ -150,12 +158,7 @@ OBJECTS = \
compile/lambda.cmo \
runtime/value.cmo \
\
schema/schema_types.cmo \
schema/schema_xml.cmo \
schema/schema_common.cmo \
schema/schema_builtin.cmo \
schema/schema_validator.cmo \
schema/schema_parser.cmo \
$(SCHEMA_OBJS) \
\
parser/location.cmo parser/url.cmo parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\
......
compile/compile.ml
View file @ 4b4c0821
......@@ -234,6 +234,11 @@ let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
ignore (Typer.get_schema sch); (* To raise the error here ... *)
let tenv = Typer.enter_schema x sch tenv in
(tenv,cenv,codes)
let find_cu (tenv,_,_) cu =
Typer.find_cu cu tenv
......@@ -259,9 +264,8 @@ let rec phrases ~run ~show ~loading ~directive =
| { descr = Ast.TypeDecl (_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in
loop (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, schema) } :: rest ->
Typer.register_schema name schema;
loop accu rest
| { descr = Ast.SchemaDecl (name, uri) } :: rest ->
loop (schema accu name uri) rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
loop (namespace accu pr ns) rest
| { descr = Ast.Using (x,cu) } :: rest ->
......
compile/lambda.ml
View file @ 4b4c0821
......@@ -20,6 +20,25 @@ let print_var_loc ppf = function
type schema_component_kind =
[ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
let serialize_schema_component_kind s x =
Serialize.Put.bits 3 s (match x with
| Some `Type -> 0
| Some `Element -> 1
| Some `Attribute -> 2
| Some `Attribute_group -> 3
| Some `Model_group -> 4
| None -> 5)
let deserialize_schema_component_kind s =
match Serialize.Get.bits 3 s with
| 0 -> Some `Type
| 1 -> Some `Element
| 2 -> Some `Attribute
| 3 -> Some `Attribute_group
| 4 -> Some `Model_group
| 5 -> None
| _ -> assert false
type expr =
| Var of var_loc
| Apply of bool * expr * expr
......@@ -36,7 +55,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * U.t * U.t
| Validate of expr * schema_component_kind * string * U.t
| RemoveField of expr * label
| Dot of expr * label
| UnaryOp of int * expr
......@@ -164,7 +183,12 @@ module Put = struct
expr s e;
branches s brs
| Validate (e,k,sch,t) ->
assert false (* TODO:Need to store a pointer to the schema ... *)
bits nbits s 13;
expr s e;
serialize_schema_component_kind s k;
string s sch;
U.serialize s t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
| RemoveField (e,l) ->
bits nbits s 14;
expr s e;
......@@ -276,7 +300,12 @@ module Get = struct
let e = expr s in
let brs = branches s in
Try (e,brs)
| 13 -> assert false
| 13 ->
let e = expr s in
let k = deserialize_schema_component_kind s in
let sch = string s in
let t = U.deserialize s in
Validate (e,k,sch,t)
| 14 ->
let e = expr s in
let l = LabelPool.deserialize s in
......
compile/lambda.mli 0 → 100644
View file @ 4b4c0821
open Ident
type var_loc =
| Stack of int
| Env of int
| Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
| External of Types.CompUnit.t * int
(* If pos < 0, the first arg is the value *)
| Global of int (* Only for the toplevel *)
| Dummy
type schema_component_kind =
[ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
type expr =
| Var of var_loc
| Apply of bool * expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches
| Const of Types.Const.t
| Pair of expr * expr
| Xml of expr * expr * expr
| Record of expr label_map
| String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches
| Map of expr * branches
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * U.t
| RemoveField of expr * label
| Dot of expr * label
| UnaryOp of int * expr
| BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t
and branches = {
brs: (Patterns.node * expr) list;
brs_tail: bool;
brs_input: Types.t;
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}
type code_item =
| Push of expr
| Pop
| Split of Patterns.node
| SetGlobal of Types.CompUnit.t * int
type code = code_item list
module Put :
sig
val unary_op : (Serialize.Put.t -> int -> unit) ref
val binary_op : (Serialize.Put.t -> int -> unit) ref
val var_loc : Serialize.Put.t -> var_loc -> unit
val expr : expr Serialize.Put.f
val branches : Serialize.Put.t -> branches -> unit
val code_item : Serialize.Put.t -> code_item -> unit
val codes : code_item list Serialize.Put.f
val compunit : Serialize.Put.t -> code_item list -> unit
end
module Get :
sig
val unary_op : (Serialize.Get.t -> int) ref
val binary_op : (Serialize.Get.t -> int) ref
val var_loc : Serialize.Get.t -> var_loc
val expr : expr Serialize.Get.f
val branches : Serialize.Get.t -> branches
val code_item : Serialize.Get.t -> code_item
val codes : code_item list Serialize.Get.f
val compunit : Serialize.Get.t -> code_item list
end
val print_var_loc : Format.formatter -> var_loc -> unit
depend
View file @ 4b4c0821
......@@ -71,17 +71,15 @@ types/builtin_defs.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx misc/ns.cmx types/sequence.cmx \
types/types.cmx types/builtin_defs.cmi
compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
types/types.cmi
types/types.cmi compile/lambda.cmi
compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx
types/types.cmx compile/lambda.cmi
runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi compile/lambda.cmo \
misc/encodings.cmi types/ident.cmo types/intervals.cmi compile/lambda.cmi \
misc/ns.cmi types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi
types/externals.cmo: parser/location.cmi types/externals.cmi
types/externals.cmx: parser/location.cmx types/externals.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
......@@ -142,6 +140,8 @@ parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
parser/location.cmx misc/ns.cmx schema/schema_parser.cmx \
types/sequence.cmx types/types.cmx parser/ulexer.cmx parser/url.cmx \
parser/parser.cmi
types/externals.cmo: parser/location.cmi types/externals.cmi
types/externals.cmx: parser/location.cmx types/externals.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
schema/schema_types.cmi types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
......@@ -186,7 +186,7 @@ runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_builtin.cmx types/sequence.cmx runtime/value.cmx \
runtime/print_xml.cmi
runtime/eval.cmo: types/ident.cmo compile/lambda.cmo types/patterns.cmi \
runtime/eval.cmo: types/ident.cmo compile/lambda.cmi types/patterns.cmi \
runtime/run_dispatch.cmi schema/schema_common.cmi schema/schema_types.cmi \
schema/schema_validator.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi runtime/eval.cmi
......@@ -195,14 +195,14 @@ runtime/eval.cmx: types/ident.cmx compile/lambda.cmx types/patterns.cmx \
schema/schema_validator.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: parser/ast.cmo runtime/eval.cmi types/ident.cmo \
compile/lambda.cmo parser/location.cmi types/patterns.cmi \
compile/lambda.cmi parser/location.cmi types/patterns.cmi \
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
compile/compile.cmi
compile/compile.cmx: parser/ast.cmx runtime/eval.cmx types/ident.cmx \
compile/lambda.cmx parser/location.cmx types/patterns.cmx \
misc/serialize.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
compile/compile.cmi
compile/operators.cmo: misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
compile/operators.cmo: misc/custom.cmo runtime/eval.cmi compile/lambda.cmi \
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
compile/operators.cmx: misc/custom.cmx runtime/eval.cmx compile/lambda.cmx \
......@@ -220,7 +220,7 @@ types/builtin.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
runtime/value.cmx types/builtin.cmi
driver/librarian.cmo: types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi types/externals.cmi types/ident.cmo \
compile/lambda.cmo parser/location.cmi parser/parser.cmi \
compile/lambda.cmi parser/location.cmi parser/parser.cmi \
misc/serialize.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
driver/librarian.cmi
driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
......@@ -240,22 +240,6 @@ driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
types/ident.cmo driver/librarian.cmi types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
types/ident.cmx driver/librarian.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi ocamliface/mltypes.cmi \
misc/ns.cmi types/sequence.cmi typing/typer.cmi types/types.cmi \
ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
compile/compile.cmx driver/config.cmx types/externals.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx ocamliface/mltypes.cmx \
misc/ns.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
ocamliface/mlstub.cmi
parser/cduce_curl.cmo: driver/config.cmi parser/url.cmi
parser/cduce_curl.cmx: driver/config.cmx parser/url.cmx
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
......@@ -311,9 +295,8 @@ types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sample.cmi: types/types.cmi
types/builtin_defs.cmi: types/atoms.cmi types/ident.cmo types/types.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmi misc/ns.cmi \
types/types.cmi
types/externals.cmi: types/types.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
......@@ -324,6 +307,7 @@ schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \
schema/schema_validator.cmi: schema/schema_types.cmi runtime/value.cmi
schema/schema_parser.cmi: schema/schema_types.cmi schema/schema_xml.cmi
parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi
typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_types.cmi typing/typed.cmo types/types.cmi
......@@ -331,9 +315,9 @@ runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/explain.cmi: types/types.cmi runtime/value.cmi
runtime/print_xml.cmi: misc/ns.cmi runtime/value.cmi
runtime/eval.cmi: types/ident.cmo compile/lambda.cmo types/types.cmi \
runtime/eval.cmi: types/ident.cmo compile/lambda.cmi types/types.cmi \
runtime/value.cmi
compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cmo \
compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cmi \
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi
compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
......@@ -341,7 +325,6 @@ compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: compile/compile.cmi types/ident.cmo typing/typer.cmi \
types/types.cmi runtime/value.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
query/query.cmi: parser/ast.cmo
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
driver/cduce.ml
View file @ 4b4c0821
......@@ -57,7 +57,7 @@ let dump_env ppf tenv cenv =
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump;
Format.fprintf ppf "Schemas: %s@."
(String.concat " " (List.map U.get_str (Typer.get_schema_names ())));
(String.concat " " (List.map U.get_str (Typer.get_schema_names tenv)));
Format.fprintf ppf "Values:@.";
Typer.iter_values tenv
(fun x t -> dump_value ppf x t (get_global_value cenv x))
......@@ -214,13 +214,15 @@ let directive ppf tenv cenv = function
| `Env ->
dump_env ppf tenv cenv
| `Print_schema schema ->
Schema_common.print_schema ppf (Typer.get_schema schema);
let uri = Typer.find_schema schema tenv in
let sch = Typer.get_schema uri in
Schema_common.print_schema ppf sch;
flush_ppf ppf
| `Print_type name ->
Typer.dump_type ppf tenv name;
flush_ppf ppf
| `Print_schema_type schema_ref ->
Typer.dump_schema_type ppf schema_ref;
Typer.dump_schema_type ppf tenv schema_ref;
flush_ppf ppf
| `Reinit_ns ->
Typer.set_ns_table_for_printer tenv
......
parser/ast.ml
View file @ 4b4c0821
......@@ -8,7 +8,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of id * ppat
| SchemaDecl of U.t * Schema_types.schema (* name, schema *)
| SchemaDecl of U.t * string (* name, uri *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.t
......
parser/parser.ml
View file @ 4b4c0821
......@@ -112,10 +112,7 @@ EXTEND
[ mk loc (Using (U.mk name, U.mk cu)) ]
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema = match Url.process uri with
| Url.Filename s -> Schema_parser.schema_of_file s
| Url.Url s -> Schema_parser.schema_of_string s in
[ mk loc (SchemaDecl (U.mk name, schema)) ]
[ mk loc (SchemaDecl (U.mk name, uri)) ]
| (name,ns) = namespace_binding ->
[ mk loc (Namespace (name, ns)) ]
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......
typing/typed.ml
View file @ 4b4c0821
......@@ -41,8 +41,8 @@ and texpr' =
| Map of texpr * branches
| Transform of texpr * branches
| Xtrans of texpr * branches
| Validate of texpr * Schema_types.component_kind * U.t * U.t
(* exp, schema component kind, schema name, element name *)
| Validate of texpr * Schema_types.component_kind * string * U.t
(* exp, schema component kind, schema uri, element name *)
| RemoveField of texpr * label
| Dot of texpr * label
......
typing/typer.ml
View file @ 4b4c0821
......@@ -16,6 +16,19 @@ let warning loc msg =
Location.html_hilight (loc,`Full)
msg
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr
exception ShouldHave of Types.descr * string
exception ShouldHave2 of Types.descr * string * Types.descr
exception WrongLabel of Types.descr * label
exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception Error of string
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
type item =
| Type of Types.t
| Val of Types.t
......@@ -26,6 +39,7 @@ type t = {
ids : item Env.t;
ns: Ns.table;
cu: Types.CompUnit.t UEnv.t;
schemas: string UEnv.t
}
let hash _ = failwith "Typer.hash"
......@@ -49,16 +63,16 @@ let deserialize_item s = match Serialize.Get.bits 1 s with
| _ -> assert false
let deserialize s =
let ids =
Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
let ns = Ns.deserialize_table s in
{ ids = ids; ns = ns; cu = UEnv.empty }
{ ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty }
let empty_env = {
ids = Env.empty;
ns = Ns.empty_table;
cu = UEnv.empty;
schemas = UEnv.empty
}
let from_comp_unit = ref (fun cu -> assert false)
......@@ -71,6 +85,12 @@ let find_cu x env =
with Not_found -> Types.CompUnit.mk x
let enter_schema x uri env =
{ env with schemas = UEnv.add x uri env.schemas }
let find_schema x env =
try UEnv.find x env.schemas
with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))
let enter_type id t env =
{ env with ids = Env.add id (Type t) env.ids }
let enter_types l env =
......@@ -167,22 +187,13 @@ let rec const env loc = function
(* I. Transform the abstract syntax of types and patterns into
the internal form *)
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr
exception ShouldHave of Types.descr * string
exception ShouldHave2 of Types.descr * string * Types.descr
exception WrongLabel of Types.descr * label
exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception Error of string
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
(* Schema *)
(* just to remember imported schemas *)
let is_registered_schema env s = UEnv.mem s env.schemas
(* uri -> schema binding *)
let schemas = State.ref "Typer.schemas" (Hashtbl.create 3)
let is_registered_schema = Hashtbl.mem !schemas
let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
......@@ -192,38 +203,43 @@ let schema_attribute_groups =
let schema_model_groups =
State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
(* raise Not_found *)
let find_schema_descr kind schema name =
let elt () = Hashtbl.find !schema_elements (schema, name) in
let typ () = Hashtbl.find !schema_types (schema, name) in
let att () = Hashtbl.find !schema_attributes (schema, name) in
let att_group () = Hashtbl.find !schema_attribute_groups (schema, name) in
let mod_group () = Hashtbl.find !schema_model_groups (schema, name) in
let rec do_try n = function
| [] -> raise Not_found
| f :: rem -> (try f () with Not_found -> do_try n rem)
in
match kind with
| Some `Element -> do_try "element" [ elt ]
| Some `Type -> do_try "type" [ typ ]
| Some `Attribute -> do_try "atttribute" [ att ]
| Some `Attribute_group -> do_try "attribute group" [ att_group ]
| Some `Model_group -> do_try "model group" [ mod_group ]
| None ->
(* policy for unqualified schema component resolution. This order should
* be consistent with Schema_component.get_component *)
do_try "component" [ elt; typ; att; att_group; mod_group ]
(* as above, but raise Error *)
let find_schema_descr' k s n =
let get_schema_fwd = ref (fun _ -> assert false)
let find_schema_descr_uri kind uri name =
try
find_schema_descr k s n
with Not_found ->
if is_registered_schema s then
ignore (!get_schema_fwd uri);
let elt () = Hashtbl.find !schema_elements (uri, name) in
let typ () = Hashtbl.find !schema_types (uri, name) in
let att () = Hashtbl.find !schema_attributes (uri, name) in
let att_group () = Hashtbl.find !schema_attribute_groups (uri, name) in
let mod_group () = Hashtbl.find !schema_model_groups (uri, name) in
let rec do_try n = function
| [] -> raise Not_found
| f :: rem -> (try f () with Not_found -> do_try n rem)
in
match kind with
| Some `Element -> do_try "element" [ elt ]
| Some `Type -> do_try "type" [ typ ]
| Some `Attribute -> do_try "atttribute" [ att ]
| Some `Attribute_group -> do_try "attribute group" [ att_group ]
| Some `Model_group -> do_try "model group" [ mod_group ]
| None ->
(* policy for unqualified schema component resolution. This order should
* be consistent with Schema_component.get_component *)
do_try "component" [ elt; typ; att; att_group; mod_group ]
with Not_found ->
raise (Error (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)))
else
raise (Error (Printf.sprintf "%s: no such schema" (U.get_str s)))
(Schema_common.string_of_component_kind kind) (U.get_str name) uri))
let find_schema_descr env kind schema name =
let uri = find_schema schema env in
find_schema_descr_uri kind uri name
(* Eliminate Recursion, propagate Sequence Capture Variables *)
......@@ -500,7 +516,7 @@ let rec derecurs env p = match p.descr with
raise_loc_generic p.loc
("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)))
| SchemaVar (kind, schema_name, component_name) ->
PType (derecurs_schema env kind schema_name component_name)
PType (find_schema_descr env.penv_tenv kind schema_name component_name)
| Recurs (p,b) -> derecurs (derecurs_def env b) p
| Internal t -> PType t
| NsT ns -> PType (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
......@@ -546,8 +562,6 @@ and derecurs_def env b =
List.iter (fun (v,p,s) -> s.pdescr <- derecurs env p) b;
env
and derecurs_schema env = find_schema_descr
let rec fv_slot s =
match s.fv with
| Some x -> x
......@@ -790,8 +804,9 @@ let dump_type ppf env name =
with Not_found ->
raise (Error (Printf.sprintf "Type %s not found" (U.get_str name)))
let dump_schema_type ppf (k, s, n) =
let descr = find_schema_descr' k s n in
let dump_schema_type ppf env (k, s, n) =
let uri = find_schema s env in
let descr = find_schema_descr_uri k uri n in
Types.Print.print ppf descr
let dump_ns ppf env =
......@@ -933,7 +948,8 @@ let rec expr env loc = function
exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))
| Validate (e,kind,schema,elt) ->
let (fv,e) = expr env loc e in
exp loc fv (Typed.Validate (e, kind, schema, elt))
let uri = find_schema schema env in
exp loc fv (Typed.Validate (e, kind, uri, elt))
| Try (e,b) ->
let (fv1,e) = expr env loc e
and (fv2,b) = branches env b in
......@@ -1154,9 +1170,9 @@ and type_check' loc env e constr precise = match e with
) t in
verify loc t constr
| Validate (e, kind, schema_name, name) ->
| Validate (e, kind, uri, name) ->
ignore (type_check env e Types.any false);
let t = find_schema_descr' kind schema_name name in
let t = find_schema_descr_uri kind uri name in
verify loc t constr
| Ref (e,t) ->
......@@ -1570,60 +1586,60 @@ module Schema_converter =
end
let get_schema name =
try
Hashtbl.find !schemas name
with Not_found ->
raise (Error (Printf.sprintf "Schema '%s' not found" (U.get_str name)))
let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas []
let get_schema_names () = Hashtbl.fold (fun n _ acc -> n :: acc) !schemas []
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found ->
let schema = match Url.process uri with
| Url.Filename s -> Schema_parser.schema_of_file s
| Url.Url s -> Schema_parser.schema_of_string s in
let register_schema schema_name schema =
if is_registered_schema schema_name then
failwith ("Redefinition of schema " ^ U.get_str schema_name)
else begin
let log_schema_component kind schema name cd_type =