Commit 03ce52d3 authored by Pietro Abate's avatar Pietro Abate

[r2005-07-07 15:03:35 by afrisch] open

Original author: afrisch
Date: 2005-07-07 15:03:35+00:00
parent 1081ca82
......@@ -232,6 +232,10 @@ let using (tenv,cenv,codes) loc x cu =
let tenv = Typer.type_using tenv loc x cu in
(tenv,cenv,codes)
let do_open (tenv,cenv,codes) loc path =
let tenv = Typer.type_open tenv loc path in
(tenv,cenv,codes)
let rec collect_funs accu = function
| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
| rest -> (accu,rest)
......@@ -258,6 +262,8 @@ let rec phrases ~run ~show ~directive =
loop (keep_ns accu b) rest
| { descr = Ast.Using (x,cu); loc = loc } :: rest ->
loop (using accu loc x cu) rest
| { descr = Ast.Open path; loc = loc } :: rest ->
loop (do_open accu loc path) rest
| { descr = Ast.EvalStatement e } :: rest ->
loop (eval ~run ~show accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
......
......@@ -240,6 +240,9 @@ let add_prefix pr ns table =
if (U.get_str pr <> "") then Hashtbl.add global_hints ns pr;
Table.add pr ns table
let merge_tables t1 t2 =
Table.fold add_prefix t2 t1
let dump_table ppf table =
Table.iter
(fun pr ns ->
......
......@@ -46,6 +46,7 @@ type table (* prefix => namespace *)
val empty_table: table (* Contains only xml *)
val def_table: table (* Contains xml,xsd,xsi *)
val add_prefix: Utf8.t -> Uri.t -> table -> table
val merge_tables: table -> table -> table
val dump_table: Format.formatter -> table -> unit
val get_table: table -> (Utf8.t * Uri.t) list
......
......@@ -16,6 +16,7 @@ and pmodule_item' =
| Namespace of U.t * ns_expr
| KeepNs of bool
| Using of U.t * U.t
| Open of U.t list
| EvalStatement of pexpr
| Directive of toplevel_directive
and debug_directive =
......
......@@ -143,6 +143,9 @@ EXTEND
| "type"; x = located_ident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
[ mk loc (Using (U.mk name, U.mk cu)) ]
| "open"; ids = LIST1 [ IDENT | keyword ] SEP "." ->
let ids = List.map (fun x -> ident x) ids in
[ mk loc (Open ids) ]
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
[ mk loc (SchemaDecl (U.mk name, uri)) ]
......
......@@ -77,12 +77,6 @@ let qname env loc t =
let ident env loc t =
protect_error_ns loc (Ns.map_attr env.ns) t
let has_value id env =
try match Env.find (Ident.ident (Ns.map_attr env.ns id)) env.ids with
| Val t -> true
| _ -> false
with Not_found | Ns.UnknownPrefix _ -> false
let parse_atom env loc t = Atoms.V.mk (qname env loc t)
let parse_ns env loc ns =
......@@ -151,7 +145,7 @@ let enter_values_dummy l env =
let value_name_ok id env =
try match Env.find id env.ids with
| Val t -> true
| Val _ | EVal _ -> true
| _ -> false
with Not_found -> true
......@@ -252,18 +246,33 @@ let find_local_type env loc id =
| Type t -> t
| _ -> raise Not_found
let check_local_value env loc id =
try match Env.find id env.ids with
| Val _ -> ()
| _ -> error loc "This identifier does not refer to a value"
with Not_found -> error loc "Unbound identifier"
let find_value id env =
try match Env.find id env.ids with
| Val t -> t
| Val t | EVal (_,_,t) -> t
| _ -> raise Not_found
with Not_found -> assert false
let do_open env cu =
let env_cu = !from_comp_unit cu in
let ids =
Env.fold
(fun n d ids ->
let d = match d with
| Val t -> EVal (cu,n,t)
| d -> d in
Env.add n d ids)
env_cu.ids
env.ids in
{ env with
ids = ids;
ns = Ns.merge_tables env.ns env_cu.ns }
let type_open env loc ids =
match find_global env loc ids with
| ECDuce cu -> do_open env cu
| _ -> error loc "This path does not refer to a CDuce unit"
module IType = struct
open Typepat
......@@ -637,8 +646,12 @@ and var env loc s =
in
exp loc Fv.empty e
| None ->
check_local_value env loc id;
exp loc (Fv.singleton id) (Typed.Var id)
try match Env.find id env.ids with
| Val _ -> exp loc (Fv.singleton id) (Typed.Var id)
| EVal (cu,id,t) -> exp loc Fv.empty (Typed.ExtVar (cu,id,t))
| _ -> error loc "This identifier does not refer to a value"
with Not_found -> error loc "Unbound identifier"
and abstraction env loc a =
let iface =
......
......@@ -33,6 +33,7 @@ val set_ns_table_for_printer: t -> unit
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_open: t -> Location.loc -> U.t list -> t
val type_keep_ns : t -> bool -> t
......@@ -48,6 +49,7 @@ val type_let_funs: t -> Ast.pexpr list ->
(* Assume that all the expressions are Abstractions *)
(* Operators *)
type type_fun = Types.t -> bool -> Types.t
......
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