Commit 88146622 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Preliminary support for allowing compilation units to have the same name as types.

parent 100f46a3
......@@ -147,8 +147,8 @@ let rec print_exn ppf = function
print_norm t;
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
| Typer.UnboundId (x,tn) ->
Format.fprintf ppf "Unbound identifier %a%s@." Ident.print x
(if tn then " (it is a type name)" else "")
Format.fprintf ppf "Unbound %sidentifier '%a'@."
(if tn then "type " else "") Ident.print x
| Typer.UnboundExtId (cu,x) ->
Format.fprintf ppf "Unbound external identifier %a:%a@."
U.print (Librarian.name cu)
......
......@@ -50,7 +50,7 @@ let mk name descr typing compile code ext_info depends =
status = `Unevaluated;
}
let magic = "CDUCE:compunit:00009"
let magic = "CDUCE:compunit:00010"
let has_obj n =
let base = U.to_string n ^ ".cdo" in
......
......@@ -250,7 +250,7 @@ EXTEND Gram
[ "map" | "match" | "with" | "try" | "xtransform"
| "if" | "then" | "else"
| "transform" | "fun" | "in"
| "let" | "type" | "debug" | "include"
| "let" | "type" | "debug" | "include" | "link"
| "and" | "or" | "validate" | "schema" | "namespace" | "ref" | "alias"
| "not" | "as" | "where" | "select" | "from" | "open"
]
......
......@@ -10,6 +10,48 @@ let print = Id.print
module IdSet = SortedList.Make(Id)
module IdMap = IdSet.Map
module Env = Map.Make(Id)
module MultiEnv : sig
type key = Id.t
type 'a t
val empty : 'a t
val is_empty : 'a t -> bool
val mem : key -> 'a t -> bool
val find : key -> 'a t -> 'a list
val add : key -> 'a -> 'a t -> 'a t
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val bindings : 'a t -> (key * 'a list) list
val filter : (key -> 'a -> bool) -> 'a t -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
end
=
struct
module M = Map.Make(Id)
type key = M.key
type 'a t = 'a list M.t
let empty = M.empty
let is_empty = M.is_empty
let mem = M.mem
(* let singleton k v = M.singleton k [v] *)
let find k m = M.find k m
let add k v m =
let l =
try find k m with
Not_found -> []
in
M.add k (v::l) m
let iter f m = M.iter (fun k l -> List.iter (fun v -> f k v) l) m
let fold f m acc =
M.fold (fun k l acc -> List.fold_left (fun acc v -> f k v acc) acc l) m acc
let bindings m = M.bindings m
let filter f m = M.fold (fun k l acc ->
match List.filter (fun v -> f k v) l with
[] -> acc
| ll -> M.add k ll acc) m M.empty
let map f m = M.map (fun l -> List.map f l) m
end
type 'a id_map = 'a IdMap.map
type fv = IdSet.t
......@@ -21,8 +63,17 @@ module LabelMap = LabelSet.Map
type label = Ns.Label.t
type 'a label_map = 'a LabelMap.map
let pp_multienv f ppf env =
let f ppf (e,v) =
let s = Id.to_string e in
Utils.pp_list ~delim:("<",">") ~sep:";" (fun ppf v -> f ppf (s,v)) ppf v
in
Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (MultiEnv.bindings env)
let pp_env f ppf env =
let f ppf (e,v) = f ppf ((Id.to_string e),v) in
let f ppf (e,v) =
let s = Id.to_string e in f ppf (s,v)
in
Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (Env.bindings env)
let pp_idmap f ppf map =
......
......@@ -43,18 +43,18 @@ type item =
| ESchemaComponent of (Types.t * Schema_validator.t)
type t = {
ids : item Env.t;
delta : Var.Set.t;
ns: Ns.table;
keep_ns: bool
ids : item MultiEnv.t;
delta : Var.Set.t;
ns: Ns.table;
keep_ns: bool
}
let pp_env ppf env =
let pp_item ppf (s,t) = match t with
|Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
|Type (t,[]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
|Type (t,al) ->
Format.fprintf ppf "type %s(%a) = %a" s
| Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
| Type (t,[]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
| Type (t,al) ->
Format.fprintf ppf "type %s (%a) = %a" s
(Utils.pp_list ~delim:("","") Var.print) al
Types.Print.pp_noname t
|_ -> ()
......@@ -67,12 +67,12 @@ let pp_env ppf env =
"Namespaces";"Caml_int" ]
in
let ids =
Env.filter (fun n _ ->
MultiEnv.filter (fun n _ ->
not(List.mem (Id.to_string n) t)
) env.ids
in
Format.printf "{ids=%a;delta=%a}"
(Ident.pp_env pp_item) ids
Format.printf "{ids=%a; delta=%a}"
(Ident.pp_multienv pp_item) ids
Var.Set.print env.delta
;;
......@@ -120,17 +120,18 @@ let type_schema env loc name uri =
let x = ident env loc name in
let (ns,sch) = !load_schema (U.to_string name) uri in
let sch = { sch_uri = uri; sch_comps = sch; sch_ns = ns } in
{ env with ids = Env.add x (ESchema sch) env.ids }
{ env with ids = MultiEnv.add x (ESchema sch) env.ids }
let empty_env = {
ids = Env.empty; (* map from expression variables to items *)
ids = MultiEnv.empty; (* map from expression variables to items *)
delta = Var.Set.empty; (* set of bounded type variables *)
ns = Ns.def_table;
keep_ns = false
}
let enter_id x i env =
{ env with ids = Env.add x i env.ids }
{ env with ids = MultiEnv.add x i env.ids }
let type_using env loc x cu =
try
......@@ -143,50 +144,69 @@ let enter_type id t env = enter_id id (Type (t,[])) env
let enter_types l env =
{ env with ids =
List.fold_left (fun accu (id,t,al) ->
Env.add id (Type (t,List.map fst al)) accu
MultiEnv.add id (Type (t,List.map fst al)) accu
) env.ids l
}
let find_id env0 env loc head x =
let id = ident env0 loc x in
try Env.find id env.ids
try MultiEnv.find id env.ids
with Not_found when head ->
try ECDuce (!load_comp_unit x)
try [ ECDuce (!load_comp_unit x) ]
with Not_found ->
raise_loc loc (UnboundCompUnit x)
let find_id_comp env0 env loc x =
if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
&& !has_ocaml_unit x)
then EOCaml (U.get_str x)
else find_id env0 env loc true x
let find_id_comp env0 env loc head x =
let l2 =
if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
&& !has_ocaml_unit x)
then [ EOCaml (U.get_str x) ]
else []
in
let l2 =
try (ECDuce (!load_comp_unit x)) :: l2
with Not_found -> l2
in
let id = ident env0 loc x in
let l1 =
try
MultiEnv.find id env.ids
with
Not_found -> []
in
match l1 @ l2 with
[] -> raise_loc loc (UnboundCompUnit x)
| l -> l
let enter_value id t env =
{ env with ids = Env.add id (Val t) env.ids }
{ env with ids = MultiEnv.add id (Val t) env.ids }
let enter_values l env =
{ env with ids =
List.fold_left (fun accu (id,t) -> Env.add id (Val t) accu) env.ids l;
{
env with ids =
List.fold_left (fun accu (id,t) ->
MultiEnv.add id (Val t) accu) env.ids l;
}
let enter_values_dummy l env =
{ env with ids =
List.fold_left (fun accu id -> Env.add id (Val Types.empty) accu) env.ids l }
List.fold_left (fun accu id -> MultiEnv.add id (Val Types.empty) accu) env.ids l }
let value_name_ok id env =
try match Env.find id env.ids with
| Val _ | EVal _ -> true
| _ -> false
try
let l = MultiEnv.find id env.ids in
List.for_all (function Val _ | EVal _ -> true
| _ -> false ) l
with Not_found -> true
let iter_values env f =
Env.iter (fun x ->
MultiEnv.iter (fun x ->
function Val t -> f x t;
| _ -> ()) env.ids
let register_types cu env =
Env.iter (fun x -> function
MultiEnv.iter (fun x -> function
| Type (t,vars) ->
let subst = List.map (fun x -> x, Types.var x) vars in
Types.Print.register_global (cu,(Ident.value x), subst) t
......@@ -209,7 +229,8 @@ let rec const env loc = function
the internal form *)
let find_schema_component sch name =
try ESchemaComponent (Env.find name sch.sch_comps)
try
ESchemaComponent (Env.find name sch.sch_comps)
with Not_found ->
raise (Error (Printf.sprintf "No component named '%s' found in schema '%s'"
(Ns.QName.to_string name) sch.sch_uri))
......@@ -219,8 +240,9 @@ let navig loc env0 (env,comp) id =
| ECDuce cu ->
let env = !from_comp_unit cu in
let c =
try find_id env0 env loc false id
with Not_found -> error loc "Unbound identifier"
try List.hd (find_id env0 env loc false id)
with Not_found ->
raise_loc loc (UnboundId ((Ns.empty, id), false))
in
let c = match c with
| Val t -> EVal (cu,ident env0 loc id,t)
......@@ -241,22 +263,36 @@ let navig loc env0 (env,comp) id =
| ESchemaComponent _ -> error loc "Schema components don't have components"
(*
| _ -> error loc "Invalid dot access"
*)
*)
exception Dummy_exn
let try_list f l =
let rec loop l exn =
match l with
[] -> raise exn
| e :: ll ->
try f e with
exn2 ->
if Pervasives.(exn = Dummy_exn) then loop ll exn2
else loop ll exn
in
loop l Dummy_exn
let rec find_global env loc ids =
match ids with
| id::rest ->
let comp = find_id env env loc (*true*) (rest != []) id in
snd (List.fold_left (navig loc env) (env,comp) rest)
let comp_list = find_id env env loc (*true*) (rest != []) id in
try_list
(fun comp -> snd (List.fold_left (navig loc env) (env,comp) rest) ) comp_list
| _ -> assert false
let eval_ns env loc = function
| `Uri ns -> ns
| `Path ids ->
match find_global env loc ids with
| ENamespace ns -> ns
| ESchema sch -> sch.sch_ns
| _ -> error loc "This path does not refer to a namespace or schema"
match find_global env loc ids with
| ENamespace ns -> ns
| ESchema sch -> sch.sch_ns
| _ -> error loc "This path does not refer to a namespace or schema"
let type_ns env loc p ns =
(* TODO: check that p has no prefix *)
......@@ -266,7 +302,7 @@ let type_ns env loc p ns =
Ns.add_prefix p ns env.ns
with Ns.UnsafeCDuceNs ->
error loc ("Cannot use reserved namespace '" ^ (U.to_string (Ns.Uri.value ns)) ^ "'"));
ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids }
ids = MultiEnv.add (Ns.empty,p) (ENamespace ns) env.ids }
let find_global_type env loc ids =
match find_global env loc ids with
......@@ -279,25 +315,40 @@ let find_global_schema_component env loc ids =
| ESchemaComponent c -> c
| _ -> error loc "This path does not refer to a schema component"
let extract f l =
let rec loop l =
match l with
[] -> raise Not_found
| e :: rest ->
match f e with
Some (v) -> v
| None -> loop rest
in loop l
let find_local_type env loc id =
match Env.find id env.ids with
| Type (t,pargs) -> (t,pargs)
| _ -> raise Not_found
extract
(function
| Type (t,pargs) -> Some ((t,pargs))
| _ -> None)
(MultiEnv.find id env.ids)
let find_value id env =
match Env.find id env.ids with
| Val t | EVal (_,_,t) -> t
| _ -> raise Not_found
extract
(function
| Val t | EVal (_,_, t) -> Some t
| _ -> None)
(MultiEnv.find id env.ids)
let do_open env cu =
let env_cu = !from_comp_unit cu in
let ids =
Env.fold
MultiEnv.fold
(fun n d ids ->
let d = match d with
| Val t -> EVal (cu,n,t)
| d -> d in
Env.add n d ids)
MultiEnv.add n d ids)
env_cu.ids
env.ids in
{ env with
......@@ -465,6 +516,12 @@ module IType = struct
&& comp_var_pat vll pll
| _ -> false
let invalid_instance_error loc s =
raise_loc_generic
loc
(Printf.sprintf "Invalid instantiation of type '%s' during its recursive definition"
(U.to_string s))
(* Ast -> symbolic type *)
let rec derecurs env p =
match p.descr with
......@@ -534,7 +591,7 @@ module IType = struct
try
let node = fst (Env.find v env.penv_derec) in
if args == [] || comp_var_pat cparams args then node else
raise_loc_generic loc (Printf.sprintf "Invalid instantiation of type %s during its recursive definition" (U.to_string id))
invalid_instance_error loc id
with Not_found ->
try
let (t, pargs), tidx =
......@@ -544,23 +601,25 @@ module IType = struct
else (find_global_type env.penv_tenv loc ids, ~-1)
in
if cidx >= 0 && tidx == cidx && not (comp_var_pat cparams args) then
raise_loc_generic loc (Printf.sprintf "Invalid instantiation of type %s during its recursive definition" (U.to_string id));
invalid_instance_error loc id;
let err s = Error s in
let l =
try
List.map2
(fun v p -> (v, typ ~err (derecurs env p))) pargs args
with Invalid_argument _ ->
raise_loc_generic loc
(Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id));
raise_loc_generic
loc
(Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id));
| Error s -> raise_loc_generic loc s
in
mk_type (Types.Subst.full_list t l)
with Not_found ->
assert (rest == []);
if args != [] then
raise_loc_generic loc
(Printf.sprintf "Unknown parametric type %s" (U.to_string id))
raise_loc_generic
loc
(Printf.sprintf "Unknown parametric type %s" (U.to_string id))
else
mk_capture v
end
......@@ -694,7 +753,7 @@ let pat = IType.pat
let type_defs = IType.type_defs
let dump_types ppf env =
Env.iter (fun v ->
MultiEnv.iter (fun v ->
function
(Type _) -> Format.fprintf ppf " %a" Ident.print v
| _ -> ()) env.ids
......@@ -754,7 +813,7 @@ let fresh_arg_name () =
"__abstr_arg" ^ (string_of_int !count_arg_name)
let is_op env s =
if (Env.mem s env.ids) then None
if (MultiEnv.mem s env.ids) then None
else
let (ns, _) = s in
if Ns.Uri.equal ns Ns.empty ||
......@@ -880,22 +939,28 @@ and dot loc env0 e args =
error loc "Only OCaml externals can have type arguments" in
let rec aux loc = function
| LocatedExpr (loc,e) -> aux loc e
| Dot (e,id) ->
(match aux loc e with
| `Val e -> `Val (dot_access loc e id)
| `Comp c -> `Comp (navig loc env0 c id))
| Dot (e,id) -> begin
let lst = aux loc e in
[
(try_list (function
| `Val e -> `Val (dot_access loc e id)
| `Comp c -> `Comp (navig loc env0 c id)) lst)
]
end
| Var id ->
(match find_id_comp env0 env0 loc id with
| Val _ -> `Val (var env0 loc id)
| c -> `Comp (env0,c))
| e -> `Val (expr env0 loc e)
List.map (function Val _ -> `Val (var env0 loc id)
| c -> `Comp (env0, c))
(find_id_comp env0 env0 loc false id)
| e -> [ `Val (expr env0 loc e) ]
in
match aux loc e with
| `Val e -> no_args (); e
| `Comp (_,EVal (cu,id,t)) ->
no_args (); exp loc Fv.empty (Typed.ExtVar (cu,id,t))
| `Comp (_,EOCamlComponent s) -> extern loc env0 s args
| _ -> error loc "This dot notation does not refer to a value"
let lst = aux loc e in
try_list (function
| `Val e -> no_args (); e
| `Comp (_,EVal (cu,id,t)) ->
no_args (); exp loc Fv.empty (Typed.ExtVar (cu,id,t))
| `Comp (_,EOCamlComponent s) -> extern loc env0 s args
| _ -> error loc "This dot notation does not refer to a value"
) lst
and extern loc env s args =
let args = List.map (typ env) args in
......@@ -922,11 +987,20 @@ and var env loc s =
in
exp loc Fv.empty e
| None ->
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"
try
try_list
(function
| Val _ -> exp loc (Fv.singleton id) (Typed.Var id)
| EVal (cu,id,t) -> exp loc Fv.empty (Typed.ExtVar (cu,id,t))
| _ ->
pp_env Format.err_formatter env;
error loc
(Format.sprintf
"identifier '%s' does not refer to a value"
(Ident.to_string id)))
(MultiEnv.find id env.ids)
with Not_found ->
raise_loc loc (UnboundId (id, false))
and abstraction env loc a =
let iface =
......@@ -1147,7 +1221,7 @@ and type_check' loc env ed constr precise = match ed with
variables defined in the interface of a *)
let env = {
env with
ids = Env.map
ids = MultiEnv.map
(fun v ->
let open Types in
match v with
......@@ -1467,7 +1541,7 @@ and branches_aux loc env targ pargs tres constr precise = function
let res = IdMap.map Types.descr res in
b.br_vars_empty <-
IdMap.domain (
IdMap.filter (fun _ t ->
IdMap.filter (fun _ t ->
Types.subtype t Sequence.nil_type)
(IdMap.restrict res b.br_vars_empty)
);
......
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