[r2004-05-05 21:14:46 by afrisch] New semantics for 'using'

Original author: afrisch
Date: 2004-05-05 21:14:47+00:00

compile/compile.ml

@@ -194,6 +194,9 @@ let namespace (tenv,cenv,codes) pr ns =
   let tenv = Typer.enter_ns pr ns tenv 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
   (tenv,cenv,codes)
@@ -222,6 +225,7 @@ let rec phrases ~run ~show ~loading ~directive =
       | { descr = Ast.Namespace (pr,ns) } :: rest ->
 	  loop (namespace accu pr ns) rest
       | { descr = Ast.Using (x,cu) } :: rest ->
+	  let cu = find_cu accu cu in
 	  loading cu;
 	  loop (using accu x cu) rest
       | { descr = Ast.EvalStatement e } :: rest ->

driver/cduce.ml

@@ -121,6 +121,10 @@ let rec print_exn ppf = function
   | Typer.UnboundId (x,tn) ->
       Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
         (if tn then " (it is a type name)" else "")
+  | Typer.UnboundExtId (cu,x) ->
+      Format.fprintf ppf "Unbound external identifier %a:%a@." 
+	U.print (Types.CompUnit.value cu)
+	U.print (Id.value x)
   | Ulexer.Error (i,j,s) ->
       let loc = Location.loc_of_pos (i,j), `Full in
       Format.fprintf ppf "Error %a:@." Location.print_loc loc;

parser/ast.ml

-(*  Abstract syntax as produced by the parsed *)
+(*  Abstract syntax as produced by the parser *)
 
 open Location
 open Ident
@@ -12,7 +12,7 @@ and pmodule_item' =
   | LetDecl of ppat * pexpr
   | FunDecl of pexpr
   | Namespace of U.t * Ns.t
-  | Using of U.t * Types.CompUnit.t
+  | Using of U.t * U.t
   | EvalStatement of pexpr
   | Directive of toplevel_directive
 and debug_directive =

parser/parser.ml

@@ -108,8 +108,8 @@ EXTEND
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
     | "type"; x = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
-    | "using"; name = IDENT; "="; cu = STRING2 ->
-	[ mk loc (Using (U.mk name, Types.CompUnit.mk (U.mk cu))) ]
+    | "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
+	[ mk loc (Using (U.mk name, U.mk cu)) ]
     | "schema"; name = IDENT; "="; uri = STRING2 ->
 	protect_op "schema";
         let schema = match Url.process uri with 
@@ -192,7 +192,7 @@ EXTEND
 	| "if" | "then"	| "else"
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
-        | "and" | "validate" | "schema" | "namespace" | "ref" | "using"
+        | "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
 	| "not" | "as"
 	]
 	-> a

typing/typer.ml

@@ -20,10 +20,12 @@ type item =
   | Type of Types.t
   | Val of Types.t
 
+module UEnv = Map.Make(U)
+
 type t = {
   ids : item Env.t;
   ns: Ns.table;
-  cu: Types.CompUnit.t Env.t;
+  cu: Types.CompUnit.t UEnv.t;
 }
 
 let hash _ = failwith "Typer.hash"
@@ -50,25 +52,23 @@ let deserialize s =
   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 = Env.empty }
+  { ids = ids; ns = ns; cu = UEnv.empty }
 
 
 let empty_env = {
   ids = Env.empty;
   ns = Ns.empty_table;
-  cu = Env.empty;
+  cu = UEnv.empty;
 }
 
 let from_comp_unit = ref (fun cu -> assert false)
 
 let enter_cu x cu env =
-  { env with cu = Env.add (ident x) cu env.cu }
+  { env with cu = UEnv.add x cu env.cu }
 
-let find_cu loc x env =
-  try Env.find x env.cu
-  with Not_found -> 
-    raise_loc_generic loc 
-      ("Unbound compunit prefix " ^ (Ident.to_string x))
+let find_cu x env =
+  try UEnv.find x env.cu
+  with Not_found -> Types.CompUnit.mk x
 
 
 let enter_type id t env =
@@ -82,7 +82,7 @@ let find_type id env =
     | Val _ -> raise Not_found
 
 let find_type_global loc cu id env =
-  let cu = find_cu loc cu env in
+  let cu = find_cu cu env in
   let env = !from_comp_unit cu in
   find_type id env
 
@@ -173,6 +173,7 @@ 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))
@@ -493,7 +494,7 @@ let rec derecurs env p = match p.descr with
 		with Not_found -> PCapture v)
 	 | cu, v -> 
 	     try 
-	       let cu = ident (U.mk cu) in
+	       let cu = U.mk cu in
 	       PType (find_type_global p.loc cu (ident v) env.penv_tenv)
 	     with Not_found ->
 	       raise_loc_generic p.loc 
@@ -842,7 +843,7 @@ let rec expr env loc = function
 	| "", id -> let id = ident id in
 	  exp loc (Fv.singleton id) (Typed.Var id)
 	| cu, id -> 
-	    let cu = find_cu loc (ident (U.mk cu)) env in
+	    let cu = find_cu (U.mk cu) env in
 	    exp loc Fv.empty (Typed.ExtVar (cu, ident id)))
   | Apply (e1,e2) -> 
       let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
@@ -1101,7 +1102,7 @@ and type_check' loc env e constr precise = match e with
       let t =
 	try find_value_global cu s env
 	with Not_found ->
-	  raise_loc loc (UnboundId (s, false) ) in
+	  raise_loc loc (UnboundExtId (cu,s) ) in
       verify loc t constr
   | Cst c -> 
       verify loc (Types.constant c) constr

typing/typer.mli

@@ -6,6 +6,7 @@ exception Constraint of Types.descr * Types.descr
 exception ShouldHave of Types.descr * string
 exception WrongLabel of Types.descr * label
 exception UnboundId of id * bool
+exception UnboundExtId of Types.CompUnit.t * id
 exception ShouldHave2 of Types.descr * string * Types.descr
 exception Error of string
 val warning: loc -> string -> unit
@@ -22,6 +23,7 @@ val register_types : Types.CompUnit.t -> t -> unit
 
 val enter_ns : U.t -> Ns.t -> t -> t
 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

web/manual/interpreter.xml

@@ -144,9 +144,13 @@ and global namespace default <code>namespace "%%...%%"</code>
 <li>Schema declaration <code>schema %%name%% = "%%...%%"</code>
 (see <local href="manual_schema">XML Schema</local>).</li>
 
-<li>Import external unit <code>using %%name%% = "%%unit%%"</code>:
-import a pre-compiled <code>%%unit%%.cdo</code> CDuce unit. Values
-and types from this unit can be referred to as <code>%%name%%:%%ident%%</code>
+<li>Import external unit <code>using %%name%% = "%%unit%%"</code>
+or <code>using %%name%% = %%unit%%</code>:
+imports a pre-compiled <code>%%unit%%.cdo</code> CDuce unit. Values
+and types from this unit can be referred to as
+<code>%%name%%:%%ident%%</code>
+instead of
+<code>%%unit%%:%%ident%%</code>.
 </li>
 
 </ul>