Commit 60f7d9ca authored by Pietro Abate's avatar Pietro Abate

[r2005-07-07 13:57:17 by afrisch] Export namespaces, schemas, ...

Original author: afrisch
Date: 2005-07-07 13:57:18+00:00
parent e4d938ef
......@@ -216,23 +216,20 @@ let type_defs (tenv,cenv,codes) typs =
let tenv = Typer.type_defs tenv typs in
(tenv,cenv,codes)
let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.type_ns tenv pr ns in
let namespace (tenv,cenv,codes) loc pr ns =
let tenv = Typer.type_ns tenv loc pr ns in
(tenv,cenv,codes)
let keep_ns (tenv,cenv,codes) k =
let tenv = Typer.type_keep_ns tenv k in
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
let tenv = Typer.type_schema tenv x sch in
let schema (tenv,cenv,codes) loc x sch =
let tenv = Typer.type_schema tenv loc x sch in
(tenv,cenv,codes)
let find_cu (tenv,_,_) cu =
Typer.find_cu cu tenv
let using (tenv,cenv,codes) x cu =
let tenv = Typer.enter_cu x cu tenv in
let using (tenv,cenv,codes) loc x cu =
let tenv = Typer.type_using tenv loc x cu in
(tenv,cenv,codes)
let rec collect_funs accu = function
......@@ -244,7 +241,7 @@ let rec collect_types accu = function
collect_types ((loc,x,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases ~run ~show ~loading ~directive =
let rec phrases ~run ~show ~directive =
let rec loop accu phs =
match phs with
| { descr = Ast.FunDecl _ } :: _ ->
......@@ -253,16 +250,14 @@ 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, uri) } :: rest ->
loop (schema accu name uri) rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
loop (namespace accu pr ns) rest
| { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
loop (schema accu loc name uri) rest
| { descr = Ast.Namespace (pr,ns); loc = loc } :: rest ->
loop (namespace accu loc pr ns) rest
| { descr = Ast.KeepNs b } :: rest ->
loop (keep_ns accu b) rest
| { descr = Ast.Using (x,cu) } :: rest ->
let cu = find_cu accu cu in
loading cu;
loop (using accu x cu) rest
| { descr = Ast.Using (x,cu); loc = loc } :: rest ->
loop (using accu loc x cu) rest
| { descr = Ast.EvalStatement e } :: rest ->
loop (eval ~run ~show accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
......@@ -278,9 +273,8 @@ let rec phrases ~run ~show ~loading ~directive =
let comp_unit ?(run=false)
?(show=fun _ _ _ -> ())
?(loading=fun _ -> ())
?(directive=fun _ _ _ -> ()) tenv cenv phs =
let (tenv,cenv,codes) = phrases ~run ~show ~loading ~directive (tenv,cenv,[]) phs in
let (tenv,cenv,codes) = phrases ~run ~show ~directive (tenv,cenv,[]) phs in
(tenv,cenv,List.rev codes)
......
......@@ -17,7 +17,6 @@ val compile_eval_expr : env -> Typed.texpr -> Value.t
val comp_unit:
?run:bool ->
?show:(id option -> Types.t -> Value.t option -> unit) ->
?loading:(Compunit.t -> unit) ->
?directive:(Typer.t -> env -> Ast.toplevel_directive -> unit) ->
Typer.t -> env -> Ast.pmodule_item list ->
......
......@@ -60,8 +60,6 @@ let dump_env ppf tenv cenv =
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns tenv;
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 tenv)));
Format.fprintf ppf "Values:@.";
Typer.iter_values tenv
(fun x t -> dump_value ppf x t (get_global_value cenv x))
......@@ -271,7 +269,6 @@ let phrases ppf phs =
let (tenv,cenv,_) =
Compile.comp_unit
~run:true ~show:(show ppf)
~loading:Librarian.run
~directive:(directive ppf)
!typing_env !compile_env phs in
typing_env := tenv;
......
......@@ -7,6 +7,8 @@ exception InvalidObject of string
exception CannotOpen of string
exception NoImplementation of U.t
let run_loaded = ref false
type t = {
name: U.t;
descr: Compunit.t;
......@@ -217,7 +219,10 @@ let get_builtins () =
let () =
Typer.from_comp_unit := (fun d -> (from_descr d).typing);
Typer.load_comp_unit := (fun name ->
if has_obj name then (load name).descr
if has_obj name then
let cu = load name in
if !run_loaded then run cu;
cu.descr
else raise Not_found);
Typer.has_static_external := Hashtbl.mem static_externals;
Compile.from_comp_unit := (fun d -> (from_descr d).compile);
......
......@@ -6,6 +6,7 @@ exception CannotOpen of string
exception NoImplementation of U.t
val name: Compunit.t -> U.t
val run_loaded: bool ref
val obj_path: string list ref
......
......@@ -124,6 +124,7 @@ let toploop () =
Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
Sys.catch_break true;
Cduce.toplevel := true;
Librarian.run_loaded := true;
Location.push_source `Stream;
let read i =
if !bol then
......
......@@ -3,6 +3,8 @@
open Location
open Ident
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
......@@ -11,7 +13,7 @@ and pmodule_item' =
| SchemaDecl of U.t * string
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.Uri.t
| Namespace of U.t * ns_expr
| KeepNs of bool
| Using of U.t * U.t
| EvalStatement of pexpr
......@@ -61,15 +63,16 @@ and pexpr =
| Map of pexpr * branches
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
| Dot of pexpr * label * ppat list
| Validate of pexpr * U.t list
| Dot of pexpr * label
| TyArgs of pexpr * ppat list
| RemoveField of pexpr * label
(* Exceptions *)
| Try of pexpr * branches
(* Other *)
| NamespaceIn of U.t * Ns.Uri.t * pexpr
| NamespaceIn of U.t * ns_expr * pexpr
| KeepNsIn of bool * pexpr
| Forget of pexpr * ppat
| Check of pexpr * ppat
......@@ -93,7 +96,7 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of (U.t option) * U.t (* optional compilation unit *)
| PatVar of U.t list
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (Location.loc * U.t * ppat) list
......
......@@ -117,8 +117,8 @@ let logical_not e = if_then_else e cst_false cst_true
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (ident op), e1), e2)
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set", []), e2)
let get_ref e = Apply (Dot (e, U.mk "get", []), cst_nil)
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set"), e2)
let get_ref e = Apply (Dot (e, U.mk "get"), cst_nil)
let let_in e1 p e2 = Match (e1, [p,e2])
let seq e1 e2 = let_in e1 pat_nil e2
let concat e1 e2 = apply_op2_noloc "@" e1 e2
......@@ -243,7 +243,7 @@ EXTEND
| "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
exp loc (Validate (e, schema, typ))
exp loc (Validate (e, [schema;typ]))
| "select"; e = SELF; "from";
l = LIST1 [ x = pat ; "in"; e = expr -> (x,e)] SEP "," ;
cond = [ "where"; c = LIST1 [ expr ] SEP "and" -> c
......@@ -302,7 +302,7 @@ EXTEND
let any = mk loc (Internal Types.any) in
let att = mk loc (Record
(true, [(label a,
(mk loc (PatVar (None,id_dummy)),
(mk loc (PatVar [id_dummy]),
None))])) in
let p = mk loc (XmlT (tag, multi_prod loc [att;any])) in
let t = (p, Pair (Var id_dummy,cst_nil)) in
......@@ -318,11 +318,11 @@ EXTEND
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let capt = mk loc (And (mk loc (PatVar (None,U.mk "$$$")),p)) in
let capt = mk loc (And (mk loc (PatVar [U.mk "$$$"]),p)) in
let xt = Xtrans (e,[capt,assign]) in
let rf = Ref (cst_nil, mk loc (Regexp (Star(Elem p)))) in
let body =
let_in rf (mk loc (PatVar (None,stk)))
let_in rf (mk loc (PatVar [stk]))
(let_in xt (mk loc (Internal Types.any)) (get_ref (Var stk)))
in
exp loc body
......@@ -335,10 +335,10 @@ EXTEND
| "no_appl"
[ e = expr; "."; l = [IDENT | keyword ];
tyargs = [ "with"; "{"; pl = LIST0 pat; "}" -> pl | -> [] ]
->
exp loc (Dot (e, label l,tyargs))
[ e = expr; "with"; "{"; tyargs = LIST0 pat; "}" ->
exp loc (TyArgs (e, tyargs))
| e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e,label l))
]
| [
"("; l = LIST1 expr SEP ","; ")" -> exp loc (tuple l)
......@@ -397,19 +397,24 @@ EXTEND
[ name =
[ name = [ IDENT | keyword ]; "=" -> ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Ns.Uri.mk (ident uri) in
`Prefix (name,ns)
ns = ns_expr -> `Prefix (name,ns)
| IDENT "on" -> `Keep true
| IDENT "off" -> `Keep false ]
] -> r ]
];
ns_expr: [
[ uri = STRING2 -> `Uri (Ns.Uri.mk (ident uri))
| ids = LIST1 [ IDENT | keyword ] SEP "." ->
let ids = List.map (fun x -> ident x) ids in
`Path ids ]
];
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar (None, snd f)) in
let p = mk loc (PatVar [snd f]) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
......@@ -581,8 +586,9 @@ EXTEND
mk loc (Constant (ident a,c))
| "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = [ IDENT | keyword ] ->
mk loc (PatVar (cu, ident a))
| ids = LIST1 [ IDENT | keyword ] SEP "." ->
let ids = List.map (fun x -> ident x) ids in
mk loc (PatVar ids)
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......@@ -643,7 +649,7 @@ EXTEND
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (None,ident l)), None)
| None -> (false, mknoloc (PatVar [ident l]), None)
| Some z -> z
in
let x = if o then mk loc (Optional x) else x in
......
......@@ -168,13 +168,13 @@ let attr_group ag = attr_uses ag.ag_def
let load_schema schema_name uri =
let schema_name = Utf8.get_str schema_name in
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global schema_name name cd_type;
Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
end
in
let env = ref Env.empty in
......@@ -196,7 +196,7 @@ let load_schema schema_name uri =
(fun x -> VType x) schema.types;
defs "element" (fun e -> Atoms.V.value e.elt_name) elt_decl
(fun x -> VElem x) schema.elements;
Obj.magic !env
schema.targetNamespace, !env
let () =
......
This diff is collapsed.
......@@ -17,8 +17,6 @@ val empty_env: t
val register_types : string -> t -> unit
(* Register types of the environment for the pretty-printer *)
val enter_cu : U.t -> Compunit.t -> t -> t
val find_cu : U.t -> t -> Compunit.t
val find_value: id -> t -> Types.t
val enter_type: id -> Types.t -> t -> t
......@@ -32,9 +30,9 @@ val dump_ns: Format.formatter -> t -> unit
val set_ns_table_for_printer: t -> unit
val type_schema: t -> U.t -> string -> t
val type_ns : t -> U.t -> Ns.Uri.t -> t
val type_using: t -> Location.loc -> U.t -> U.t -> t
val type_schema: t -> Location.loc -> U.t -> string -> t
val type_ns : t -> Location.loc -> U.t -> Ast.ns_expr -> t
val type_keep_ns : t -> bool -> t
......@@ -50,8 +48,6 @@ val type_let_funs: t -> Ast.pexpr list ->
(* Assume that all the expressions are Abstractions *)
val get_schema_names: t -> U.t list (** registered schema names *)
(* Operators *)
type type_fun = Types.t -> bool -> Types.t
......@@ -70,4 +66,4 @@ val has_static_external: (string -> bool) ref
val load_schema:
(U.t -> string -> (Types.t * Schema_validator.t) Ident.Env.t) ref
(string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) 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