Commit 1dff15fb authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-03-13 13:59:33 by afrisch] Menage

Original author: afrisch
Date: 2005-03-13 13:59:34+00:00
parent 8c6339bb
......@@ -238,15 +238,15 @@ let let_funs ~run ~show (tenv,cenv,codes) funs =
(tenv,cenv,List.rev_append code codes)
let type_defs (tenv,cenv,codes) typs =
let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
let tenv = Typer.type_defs tenv typs in
(tenv,cenv,codes)
let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in
let tenv = Typer.type_ns tenv pr ns in
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
let tenv = Typer.enter_schema x sch tenv in
let tenv = Typer.type_schema tenv x sch in
(tenv,cenv,codes)
let find_cu (tenv,_,_) cu =
......
(* TODO:
- rewrite type-checking of operators to propagate constraint
- check whether it is worth using recursive hash-consing internally
*)
......@@ -13,8 +12,6 @@ let (<) (x:int) y = x < y
let (>=) (x:int) y = x >= y
let (>) (x:int) y = x > y
let debug_schema = false
let warning loc msg =
let v = Location.get_viewport () in
let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
......@@ -65,8 +62,8 @@ let check _ = failwith "Typer.check"
let load_schema_fwd = ref (fun x uri -> assert false)
let enter_schema x uri env =
let sch = !load_schema_fwd x uri in
let type_schema env x uri =
!load_schema_fwd x uri;
{ env with cu = UEnv.add x (ESchema uri) env.cu }
(* TODO: filter out builtin defs ? *)
......@@ -97,7 +94,7 @@ let deserialize s =
(Serialize.Get.pair U.deserialize Serialize.Get.string) s in
let env =
{ ids = ids; ns = ns; cu = UEnv.empty } in
List.fold_left (fun env (name,uri) -> enter_schema name uri env) env schs
List.fold_left (fun env (name,uri) -> type_schema env name uri) env schs
let empty_env = {
......@@ -183,7 +180,7 @@ let set_ns_table_for_printer env =
let get_ns_table tenv = tenv.ns
let enter_ns p ns env =
let type_ns env p ns =
{ env with ns = Ns.add_prefix p ns env.ns }
let protect_error_ns loc f x =
......@@ -238,12 +235,13 @@ let rec const env loc = function
(* Schema *)
(* uri -> schema binding *)
let schemas = Hashtbl.create 3
let schemas = Hashtbl.create 13
let find_schema_component uri name =
Env.find (Ident.ident name) (Hashtbl.find schemas uri)
let find_schema_descr uri (name : Ns.qname) =
try
let sch = snd (Hashtbl.find schemas uri) in
fst (Env.find (Ident.ident name) sch)
try fst (find_schema_component uri name)
with Not_found ->
raise (Error (Printf.sprintf "No component named '%s' found in schema '%s'"
(Ns.QName.to_string name) uri))
......@@ -1024,7 +1022,7 @@ module IType = struct
(v',t)) b b' in
List.iter (fun (v,t) -> Types.Print.register_global
(Types.CompUnit.get_current ()) (Id.value v) t) b;
b
enter_types b env
let type_defs env b =
try type_defs env b
......@@ -1202,7 +1200,7 @@ let rec expr env loc = function
and (fv2,b) = branches env b in
exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
| NamespaceIn (pr,ns,e) ->
let env = enter_ns pr ns env in
let env = type_ns env pr ns in
expr env loc e
| Ref (e,t) ->
let (fv,e) = expr env loc e and t = typ env t in
......@@ -1844,17 +1842,6 @@ module Schema_converter =
| { st_name = Some name }
when Schema_builtin.is name ->
Schema_builtin.cd_type (Schema_builtin.get name)
(* This is non-sense ...
| Derived (_, _, { enumeration = Some values }, _) -> (* enumeration *)
itype (Types.choice_of_list
(List.map (fun c -> Types.constant (Value.inv_const (Lazy.force c)))
values))
| Derived (_, _, ({ maxInclusive = Some _ } as facets), _)(* boundaries *)
| Derived (_, _, ({ maxExclusive = Some _ } as facets), _)
| Derived (_, _, ({ minInclusive = Some _ } as facets), _)
| Derived (_, _, ({ minExclusive = Some _ } as facets), _) ->
itype (Types.interval (Schema_common.get_interval facets))
*)
| { st_variety = Atomic st } ->
(* TODO: apply facets *)
Schema_builtin.cd_type (Schema_builtin.of_st st)
......@@ -2006,7 +1993,7 @@ open Schema_common
open Schema_converter
open Schema_validator
let register_schema schema_name uri schema =
let register_schema schema_name uri =
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global (Types.CompUnit.mk schema_name)
......@@ -2026,6 +2013,7 @@ let register_schema schema_name uri schema =
env := Env.add (Ident.ident name) (cd_type, v def) !env
) lst
in
let schema = Schema_parser.schema_of_uri uri in
(* defs "attribute" (fun a -> a.attr_name) att_decl
(fun _ _ -> assert false) schema.attributes; *)
defs "attribute group" (fun ag -> ag.ag_name) attr_group
......@@ -2035,21 +2023,14 @@ let register_schema schema_name uri schema =
defs "type" name_of_type_definition type_def validate_type schema.types;
defs "element" (fun e -> e.elt_name) elt_decl
validate_element schema.elements;
!env
Hashtbl.add schemas uri !env
let real_load_schema schema_name uri =
let schema = Schema_parser.schema_of_uri uri in
let types = register_schema schema_name uri schema in
Hashtbl.add schemas uri (schema,types);
schema
let load_schema name uri =
try fst (Hashtbl.find schemas uri)
with Not_found -> real_load_schema name uri
if not (Hashtbl.mem schemas uri) then register_schema name uri
let get_schema_validator uri name =
let name = Ident.ident name in
snd (Env.find name (snd (Hashtbl.find schemas uri)))
snd (find_schema_component uri name)
let () = load_schema_fwd := load_schema
......
open Ident
open Location
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr
......@@ -12,38 +11,25 @@ exception Error of string
exception Warning of string * Types.t
val warning: loc -> string -> unit
val error: loc -> string -> 'a
include Custom.T
val from_comp_unit: (Types.CompUnit.t -> t) ref
val has_comp_unit: (U.t -> bool) ref
val has_ocaml_unit: (U.t -> bool) ref
val has_static_external: (string -> bool) ref
val empty_env: t
val get_ns_table : t -> Ns.table
val register_types : Types.CompUnit.t -> t -> unit
(* Register types of the environment for the pretty-printer *)
val enter_ns : U.t -> Ns.t -> t -> t
val enter_schema: U.t -> string -> t -> t
val find_schema: U.t -> t -> string
val enter_cu : U.t -> Types.CompUnit.t -> t -> t
val find_cu : U.t -> t -> Types.CompUnit.t
val enter_value: id -> Types.t -> t -> t
val enter_values: (id * Types.t) list -> t -> t
val find_value: id -> t -> Types.t
val iter_values: t -> (id -> Types.t -> unit) -> unit
val enter_type: id -> Types.t -> t -> t
val enter_types: (id * Types.t) list -> t -> t
val find_type: id -> t -> Types.t
val iter_values: t -> (id -> Types.t -> unit) -> unit
val type_defs: t -> (Location.loc * U.t * Ast.ppat) list -> (id * Types.t) list
val typ: t -> Ast.ppat -> Types.Node.t
val pat: t -> Ast.ppat -> Patterns.node
......@@ -51,8 +37,14 @@ val dump_types: Format.formatter -> t -> unit
val dump_ns: Format.formatter -> t -> unit
val set_ns_table_for_printer: t -> unit
val type_expr:
t -> Ast.pexpr -> Typed.texpr * Types.descr
val type_schema: t -> U.t -> string -> t
val type_ns : t -> U.t -> Ns.t -> t
val type_expr: t -> Ast.pexpr -> Typed.texpr * Types.descr
val type_defs: t -> (Location.loc * U.t * Ast.ppat) list -> t
val type_let_decl: t -> Ast.ppat -> Ast.pexpr ->
t * Typed.let_decl * (id * Types.t) list
......@@ -62,12 +54,6 @@ val type_let_funs: t -> Ast.pexpr list ->
(* Assume that all the expressions are Abstractions *)
val flatten: (Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
(** {2 Schema stuff} *)
val get_schema_validator: string -> Ns.qname -> Value.t -> Value.t
val get_schema_names: t -> U.t list (** registered schema names *)
......@@ -76,3 +62,4 @@ val get_schema_names: t -> U.t list (** registered schema names *)
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
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