[r2003-10-08 21:24:38 by cvscast] Separate compilation

Original author: cvscast
Date: 2003-10-08 21:25:22+00:00

Makefile.distrib

@@ -66,7 +66,7 @@ uninstall:
 
 # Source directories 
 
-DIRS = misc parser schema typing types compile runtime driver module
+DIRS = misc parser schema typing types compile runtime driver
 CLEAN_DIRS = $(DIRS) tools tests
 
 # Objects to build
@@ -75,7 +75,7 @@ OBJECTS = \
  misc/stats.cmo \
  misc/serialize.cmo misc/custom.cmo \
  misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
- misc/pretty.cmo misc/ns.cmo \
+ misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo \
  \
  types/sortedList.cmo types/boolean.cmo types/ident.cmo \
  types/intervals.cmo types/chars.cmo types/atoms.cmo \
@@ -100,7 +100,7 @@ OBJECTS = \
  compile/compile.cmo \
  compile/operators.cmo \
  \
- types/builtin.cmo driver/cduce.cmo
+ types/builtin.cmo driver/librarian.cmo driver/cduce.cmo
 
 CDUCE = $(OBJECTS) driver/run.cmo
 WEBIFACE  = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
@@ -173,10 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml
 	(cd web/examples; ../../cduce --quiet build.cd --arg examples.xml)
 
 webpages: cduce web/site.cdo
-	(cd web; ../cduce --run site.cdo  --arg site.xml)
+	(cd web; ../cduce --run site  --arg site.xml)
 
-web/site.cdo: cduce web/site.cd
-	./cduce --compile web/site.cd
+web/site.cdo: cduce web/xhtml.cdo web/site.cd
+	(cd web; ../cduce --compile site)
+
+web/xhtml.cdo: cduce web/xhtml.cd
+	(cd web; ../cduce --compile xhtml)
 
 website: webpages webiface
 

compile/compile.ml

@@ -26,10 +26,19 @@ let find x env =
   with Not_found -> 
     failwith ("Compile: cannot find " ^ (Ident.to_string x))
 
+let from_comp_unit = ref (fun cu -> assert false)
+
+let find_ext cu x =
+  let env = !from_comp_unit cu in
+  match find x env with
+    | Global i -> ExtVar (cu,i)
+    | _ -> assert false
+
 let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
 and compile_aux env tail = function
   | Typed.Forget (e,_) -> compile env tail e
   | Typed.Var x -> Var (find x env)
+  | Typed.ExtVar (cu,x) -> find_ext cu x
   | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
   | Typed.Abstraction a -> compile_abstr env a
   | Typed.Cst c -> Const c
@@ -155,6 +164,10 @@ let namespace (tenv,cenv,codes) pr ns =
   let tenv = Typer.enter_ns pr ns tenv in
   (tenv,cenv,codes)
 
+let using (tenv,cenv,codes) x cu =
+  let tenv = Typer.enter_cu x cu tenv in
+  (tenv,cenv,codes)
+
 let rec collect_funs accu = function
   | { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
   | rest -> (accu,rest)
@@ -176,6 +189,8 @@ let rec phrases accu phs = match phs with
       phrases accu rest
   | { descr = Ast.Namespace (pr,ns) } :: rest ->
       phrases (namespace accu pr ns) rest
+  | { descr = Ast.Using (x,cu) } :: rest ->
+      phrases (using accu x cu) rest
   | { descr = Ast.EvalStatement e } :: rest ->
       phrases (eval accu e) rest
   | { descr = Ast.LetDecl (p,e) } :: rest ->

compile/compile.mli

@@ -2,7 +2,12 @@ open Ident
 open Lambda
 
 type env
+val from_comp_unit: (Types.CompUnit.t -> env) ref
+
 val empty : env
+val serialize: env Serialize.Put.f
+val deserialize: env Serialize.Get.f
+
 val enter_global : env -> id -> env
 val enter_globals : env -> id list -> env
 val find : id -> env -> var_loc

compile/lambda.ml

@@ -8,6 +8,7 @@ type var_loc =
 
 type expr = 
   | Var of var_loc
+  | ExtVar of Types.CompUnit.t * int
   | Apply of bool * expr * expr
   | Abstraction of var_loc array * (Types.t * Types.t) list * branches
 
@@ -150,6 +151,10 @@ module Put = struct
 	bits nbits s 18;
 	expr s e;
 	Types.Node.serialize s t
+    | ExtVar (cu,pos) ->
+	bits nbits s 19;
+	Types.CompUnit.serialize s cu;
+	int s pos
 	  
   and branches s brs =
     list (pair Patterns.Node.serialize expr) s brs.brs;
@@ -254,6 +259,10 @@ module Get = struct
 	  let e = expr s in
 	  let t = Types.Node.deserialize s in
 	  Ref (e,t)
+      | 19 ->
+	  let cu = Types.CompUnit.deserialize s in
+	  let pos = int s in
+	  ExtVar (cu,pos)
       | _ -> assert false
 
   and branches s =

depend

@@ -20,6 +20,8 @@ misc/ns.cmo: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/pool.cmi
     misc/serialize.cmi misc/state.cmi misc/ns.cmi 
 misc/ns.cmx: misc/q_symbol.cmo misc/custom.cmx misc/encodings.cmx misc/pool.cmx \
     misc/serialize.cmx misc/state.cmx misc/ns.cmi 
+misc/inttbl.cmo: misc/q_symbol.cmo misc/inttbl.cmi 
+misc/inttbl.cmx: misc/q_symbol.cmo misc/inttbl.cmi 
 types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi 
 types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi 
 types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi 
@@ -40,12 +42,14 @@ types/normal.cmo: misc/q_symbol.cmo types/normal.cmi
 types/normal.cmx: misc/q_symbol.cmo types/normal.cmi 
 types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \
     misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \
-    types/normal.cmi misc/ns.cmi misc/pretty.cmi misc/serialize.cmi \
-    types/sortedList.cmi misc/state.cmi misc/stats.cmi types/types.cmi 
+    misc/inttbl.cmi types/normal.cmi misc/ns.cmi misc/pool.cmi \
+    misc/pretty.cmi misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
+    misc/stats.cmi types/types.cmi 
 types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \
     misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
-    types/normal.cmx misc/ns.cmx misc/pretty.cmx misc/serialize.cmx \
-    types/sortedList.cmx misc/state.cmx misc/stats.cmx types/types.cmi 
+    misc/inttbl.cmx types/normal.cmx misc/ns.cmx misc/pool.cmx \
+    misc/pretty.cmx misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
+    misc/stats.cmx types/types.cmi 
 types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
     types/ident.cmo misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
     types/types.cmi types/patterns.cmi 
@@ -159,11 +163,11 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
     schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
     typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
 compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
-    parser/location.cmi types/patterns.cmi typing/typed.cmo typing/typer.cmi \
-    types/types.cmi compile/compile.cmi 
+    parser/location.cmi types/patterns.cmi misc/serialize.cmi \
+    typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi 
 compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx compile/lambda.cmx \
-    parser/location.cmx types/patterns.cmx typing/typed.cmx typing/typer.cmx \
-    types/types.cmx compile/compile.cmi 
+    parser/location.cmx types/patterns.cmx misc/serialize.cmx \
+    typing/typed.cmx typing/typer.cmx types/types.cmx compile/compile.cmi 
 compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
     parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
     runtime/value.cmi compile/operators.cmi 
@@ -180,18 +184,26 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
     parser/location.cmx misc/ns.cmx compile/operators.cmx \
     runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
     runtime/value.cmx types/builtin.cmi 
+driver/librarian.cmo: misc/q_symbol.cmo types/builtin.cmi compile/compile.cmi \
+    misc/encodings.cmi runtime/eval.cmi types/ident.cmo compile/lambda.cmo \
+    parser/location.cmi parser/parser.cmi types/sequence.cmi \
+    misc/serialize.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
+    driver/librarian.cmi 
+driver/librarian.cmx: misc/q_symbol.cmo types/builtin.cmx compile/compile.cmx \
+    misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
+    parser/location.cmx parser/parser.cmx types/sequence.cmx \
+    misc/serialize.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
+    driver/librarian.cmi 
 driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmi \
-    runtime/eval.cmi runtime/explain.cmi types/ident.cmo compile/lambda.cmo \
+    runtime/eval.cmi runtime/explain.cmi types/ident.cmo driver/librarian.cmi \
     parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
-    types/sample.cmi types/sequence.cmi misc/serialize.cmi misc/state.cmi \
-    typing/typed.cmo typing/typer.cmi types/types.cmi parser/ulexer.cmi \
-    runtime/value.cmi driver/cduce.cmi 
+    types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \
+    types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi 
 driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx compile/compile.cmx \
-    runtime/eval.cmx runtime/explain.cmx types/ident.cmx compile/lambda.cmx \
+    runtime/eval.cmx runtime/explain.cmx types/ident.cmx driver/librarian.cmx \
     parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
-    types/sample.cmx types/sequence.cmx misc/serialize.cmx misc/state.cmx \
-    typing/typed.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
-    runtime/value.cmx driver/cduce.cmi 
+    types/sample.cmx misc/state.cmx typing/typed.cmx typing/typer.cmx \
+    types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi 
 driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
     parser/location.cmi types/sequence.cmi misc/state.cmi misc/stats.cmi \
     parser/ulexer.cmi runtime/value.cmi 
@@ -212,7 +224,7 @@ types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo
 types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo 
 types/atoms.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi 
 types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
-    types/ident.cmo types/intervals.cmi 
+    types/ident.cmo types/intervals.cmi misc/inttbl.cmi 
 types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
     types/ident.cmo types/types.cmi 
 types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi 
@@ -234,11 +246,11 @@ runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
 runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi 
 runtime/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi 
 runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
-    runtime/value.cmi 
+    types/types.cmi runtime/value.cmi 
 compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
-    typing/typed.cmo typing/typer.cmi 
+    misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi 
 compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
     typing/typer.cmi types/types.cmi runtime/value.cmi 
 types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi 
-driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo misc/serialize.cmi types/types.cmi \
-    runtime/value.cmi 
+driver/librarian.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi 
+driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo types/types.cmi runtime/value.cmi 

driver/cduce.ml

@@ -250,6 +250,9 @@ let rec phrases ppf phs = match phs with
   | { descr = Ast.Namespace (pr,ns) } :: rest ->
       typing_env := Typer.enter_ns pr ns !typing_env;
       phrases ppf rest
+  | { descr = Ast.Using (x,cu) } :: rest ->
+      typing_env := Typer.enter_cu x cu !typing_env;
+      phrases ppf rest
   | { descr = Ast.EvalStatement e } :: rest ->
       ignore (eval ppf e);
       phrases ppf rest
@@ -298,55 +301,25 @@ let run rule ppf ppf_err input =
 let script = run Parser.prog
 let topinput = run Parser.top_phrases
 
-let comp_unit src = 
-  try 
-    let ic = open_in src in
-    Location.push_source (`File src);
-    let input = Stream.of_channel ic in
-    match parse Parser.prog input with
-      | Some p ->
-	  close_in ic;
-	  let argv = ident (U.mk "argv") in
-	  let (tenv,cenv,codes) = 
-	    Compile.comp_unit 
-	      (Typer.enter_value argv (Sequence.star Sequence.string)
-		 Builtin.env)
-	      (Compile.enter_global Compile.empty argv)
-	      p in
-	  codes
-      | None -> exit 1
-    with exn -> catch_exn Format.err_formatter exn; exit 1
-
-let run_code argv codes =
+let compile src =
   try
-    Eval.L.push argv;
-    List.iter Eval.L.eval codes
+    let id = Types.CompUnit.mk (U.mk_latin1 src) in
+    Librarian.compile id;
+    Librarian.save id;
+    exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
-
-
-let compile src =
-  let codes = comp_unit src in
-  let oc = open_out ((prefix src ".cd") ^ ".cdo") in
-  let codes_s = Serialize.Put.run Lambda.Put.compunit codes in
-  output_string oc codes_s;
-  close_out oc;
-  exit 0
   
 let compile_run src argv =
-  run_code argv (comp_unit src)
+  try
+    let id = Types.CompUnit.mk (U.mk_latin1 src) in
+    Librarian.compile id;
+    Librarian.run argv id
+  with exn -> catch_exn Format.err_formatter exn; exit 1
 
 let run obj argv =  
-  let ic = open_in obj in
-  let len = in_channel_length ic in
-  let codes = String.create len in
-  really_input ic codes 0 len;
-  close_in ic;
-  let codes = Serialize.Get.run Lambda.Get.compunit codes in
-  run_code argv codes
-
-
-let serialize_typing_env t () =
-  Typer.serialize t !typing_env
+  try
+    let id = Types.CompUnit.mk (U.mk_latin1 obj) in
+    Librarian.import id;
+    Librarian.run argv id
+  with exn -> catch_exn Format.err_formatter exn; exit 1
 
-let deserialize_typing_env t =
-  typing_env := Typer.deserialize t

driver/cduce.mli

@@ -8,9 +8,6 @@ val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
 
 val dump_env : Format.formatter -> unit
 
-val serialize_typing_env : Serialize.Put.t -> unit -> unit
-val deserialize_typing_env : Serialize.Get.t -> unit
-
 val compile: string -> unit
 val compile_run: string -> Value.t -> unit
 val run: string -> Value.t -> unit

driver/librarian.ml

+open Location
+open Ident
+
+
+module C = Types.CompUnit
+
+type t = {
+  typing: Typer.t;
+  compile: Compile.env;
+  code: Lambda.code_item list;
+  mutable digest: Digest.t option;
+  mutable vals: Value.t array option;
+  mutable depends: C.t list
+}
+
+let mk (typing,compile,code) =
+  { typing = typing;
+    compile = compile;
+    code = code;
+    digest = None;
+    vals = None;
+    depends = [];
+  }
+
+let magic = "CDUCE:compunit:00001"
+
+let tbl = C.Tbl.create ()
+
+let find id =
+  try C.Tbl.find tbl id
+  with Not_found -> assert false
+
+let serialize s cu =
+  Serialize.Put.magic s magic;
+  Typer.serialize s cu.typing;
+  Compile.serialize s cu.compile;
+  Lambda.Put.codes s cu.code
+
+let deserialize s =
+  Serialize.Get.magic s magic;
+  let typing = Typer.deserialize s in
+  let compile = Compile.deserialize s in
+  let code = Lambda.Get.codes s in
+  mk (typing,compile,code)
+
+let serialize_dep=
+  Serialize.Put.list 
+    (Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)
+
+let deserialize_dep =
+  Serialize.Get.list
+    (Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
+
+
+let source_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cd"
+let object_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cdo"
+
+
+let save id =
+  let cu = find id in
+  C.enter id;
+  let raw = Serialize.Put.run serialize cu in
+  let depend = C.close_serialize () in
+  C.leave ();
+
+(*
+  print_endline "Dependencies:";
+  List.iter (fun x -> print_endline (object_filename x)) depend;
+  flush stdout;
+*)
+  let depend = 
+    try List.map 
+      (fun id ->
+	 match (C.Tbl.find tbl id).digest with
+	   | Some d -> (C.value id, d)
+	   | None -> assert false
+      ) depend
+    with Not_found -> assert false in
+
+  let depend = Serialize.Put.run serialize_dep depend in
+  let digest = Digest.string raw in
+  let oc = open_out (object_filename id) in
+  output_value oc (digest,depend,raw);
+  close_out oc
+  
+  
+let check_digest exp digest =
+  match digest with
+    | Some x ->
+	if exp <> x then failwith "Inconsistent checksum"
+    | None -> 
+	assert false
+
+let loop = C.Tbl.create ()
+let check_loop id = 
+  try 
+    C.Tbl.find loop id;
+    failwith "Loop between compilation units"
+  with Not_found -> 
+    C.Tbl.add loop id ()
+
+let depends = ref []
+let during_compile = ref false
+
+let rec compile id =
+  check_loop id;
+  let src = source_filename id in
+  let ic = open_in src in
+  Location.push_source (`File src);
+  let input = Stream.of_channel ic in
+  let p = 
+    try Parser.prog input 
+    with
+    | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
+    | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
+  in
+  close_in ic;
+  let argv = ident (U.mk "argv") in
+  during_compile := true;
+  C.enter id;
+  let cu = mk 
+	     (
+	       Compile.comp_unit 
+		(Typer.enter_value argv (Sequence.star Sequence.string)
+		   Builtin.env)
+		(Compile.enter_global Compile.empty argv)
+		p
+	     ) in
+  C.Tbl.add tbl id cu;
+  C.leave ();
+  during_compile := false;
+  cu.depends <- !depends;
+  depends := []
+
+let rec load id =
+  try 
+    C.Tbl.find tbl id
+  with Not_found ->
+    check_loop id;
+    if !during_compile then depends := id :: !depends;
+(*    Printf.eprintf "load %s: start\n" (object_filename id);
+    flush stderr; *)
+    let ic = open_in (object_filename id) in
+    let (dig, depend, raw) = input_value ic in
+    close_in ic;
+    let depend = Serialize.Get.run deserialize_dep depend in
+    List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
+    C.enter id;
+    let cu = Serialize.Get.run deserialize raw in
+    C.leave ();
+    cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
+    cu.digest <- Some dig;
+    C.Tbl.add tbl id cu;
+    cu
+
+and load_check id exp =
+  let cu = load id in
+  check_digest exp cu.digest
+
+let rec run argv id =
+  let cu = find id in
+  List.iter (run argv) cu.depends;
+  Eval.L.push argv;
+  List.iter Eval.L.eval cu.code;
+  cu.vals <- Some (Eval.L.comp_unit ())
+  
+let import id = ignore (load id)
+
+let () =
+  Typer.from_comp_unit := (fun cu -> (load cu).typing);
+  Compile.from_comp_unit := (fun cu -> (load cu).compile);
+  Eval.L.from_comp_unit := (fun cu i ->
+			    match (load cu).vals with
+			      | None -> assert false
+			      | Some a -> a.(i))
+
+

driver/librarian.mli

+val compile: Types.CompUnit.t -> unit
+val run:  Value.t -> Types.CompUnit.t -> unit
+val import: Types.CompUnit.t -> unit
+val save: Types.CompUnit.t -> unit
+

misc/inttbl.ml

+module type S = sig
+  type key
+  type 'a t
+
+  val create: unit -> 'a t
+  val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
+  val clear: 'a t -> unit
+  val add: 'a t -> key -> 'a -> unit
+  val find: 'a t -> key -> 'a
+end
+
+type key = int
+type 'a t = 'a option array ref
+
+let create () = ref (Array.create 16 None)
+
+let clear t = t := Array.create 16 None
+
+let fold t f x =
+  let rec aux i x =
+    if i < 0 then x 
+    else
+      let x = 
+	match !t.(i) with
+	  | Some y -> f i y x
+	  | None -> x 
+      in
+      aux (pred i) x
+  in
+  aux (pred (Array.length !t)) x
+    
+
+let add t i x =
+  let l = Array.length !t in
+  if i >= l then (
+    let n = max (i + 1) (l * 2) in
+    let a = Array.create n None in
+    Array.blit !t 0 a 0 l;
+    t := a;
+  );
+  (!t).(i) <- Some x
+
+let find t i =
+  if i >= Array.length !t then raise Not_found
+  else match (!t).(i) with
+    | None -> raise Not_found
+    | Some x -> x
+    

misc/inttbl.mli

+module type S = sig
+  type key
+  type 'a t
+
+  val create: unit -> 'a t
+  val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
+  val clear: 'a t -> unit
+  val add: 'a t -> key -> 'a -> unit
+  val find: 'a t -> key -> 'a
+end
+
+include S with type key = int

misc/ns.mli

 open Encodings
 
+val split_qname: Utf8.t -> string * Utf8.t
+
 exception UnknownPrefix of Utf8.t
 
 include Custom.T with type t = int  (* Namespaces (URIs) *)

parser/ast.ml

@@ -14,6 +14,7 @@ and pmodule_item' =
   | LetDecl of ppat * pexpr
   | FunDecl of pexpr
   | Namespace of U.t * Ns.t
+  | Using of U.t * Types.CompUnit.t
   | EvalStatement of pexpr
   | Debug of debug_directive
   | Directive of toplevel_directive
@@ -37,7 +38,7 @@ and pexpr =
   | LocatedExpr of loc * pexpr
 
   (* CDuce is a Lambda-calculus ... *)
-  | Var of id
+  | Var of U.t
   | Apply of pexpr * pexpr
   | Abstraction of abstr
       
@@ -84,7 +85,7 @@ and branches = (ppat * pexpr) list
 
 and ppat = ppat' located
 and ppat' =
-  | PatVar of id
+  | PatVar of U.t
   | SchemaVar of  (* type/pattern schema variable *)
       schema_item_kind * string * string
   | Cst of pexpr

parser/parser.ml

@@ -101,6 +101,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))) ]
     | "schema"; name = IDENT; "="; uri = STRING2 ->
 	protect_op "schema";
         let schema_doc = Schema_xml.pxp_tree_of uri in
@@ -168,7 +170,7 @@ EXTEND
 	| "if" | "then"	| "else"
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
-        | "and" | "validate" | "schema" | "namespace" | "ref"
+        | "and" | "validate" | "schema" | "namespace" | "ref" | "using"
 	]
 	-> a
     ]
@@ -235,7 +237,7 @@ EXTEND
 	let re = Star(Alt(SeqCapture(id_dummy,Elem p), Elem any)) in
 	let ct = mk loc (Regexp (re,any)) in
         let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
-	let b = (p,  Var id_dummy) in
+	let b = (p,  Var (Id.value id_dummy)) in
 	exp loc (Transform (e,[b]))
     ]
     |
@@ -290,7 +292,7 @@ EXTEND
     | s = STRING2 ->
 	let s = U.mk s in
 	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
-    | a = IDENT -> exp loc (Var (ident a))
+    | a = IDENT -> exp loc (Var (U.mk a))
     | "!"; e = expr ->
 	exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
     | i = INT -> exp loc (Integer (Intervals.V.mk i))
@@ -333,7 +335,7 @@ EXTEND
   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 f) in
+	let p = mk loc (PatVar (Id.value 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)
@@ -467,7 +469,7 @@ EXTEND
           in
           mk loc (SchemaVar (kind, schema, typ))
       | a = IDENT -> 
-	  mk loc (PatVar (ident a))
+	  mk loc (PatVar (U.mk a))
       | i = INT ; "--"; j = INT -> 
           let i =  Intervals.V.mk i 
 	  and j =  Intervals.V.mk j in

runtime/eval.ml

@@ -27,6 +27,7 @@ let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
 let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.Forget (e,_) -> eval env e
   | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
+  | Typed.ExtVar _ -> assert false
   | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
   | Typed.Abstraction a -> eval_abstraction env a
   | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
@@ -291,6 +292,11 @@ let stack = ref (Array.create 1024 Value.Absent)
 let frame = ref 0
 let sp = ref 0
 
+let comp_unit () =
+  let r = Array.sub !stack 0 !sp in
+  sp := 0;
+  r
+
 let dump ppf =
   Format.fprintf ppf "sp = %i   frame = %i@." !sp !frame;
   for i = 0 to !sp - 1 do
@@ -316,6 +322,8 @@ let push x =
 
 let calls = ref 0
 
+let from_comp_unit = ref (fun cu pos -> assert false)
+
 let eval_var env = function
   | Env i -> env.(i)
   | Global i -> !stack.(i)
@@ -324,6 +332,7 @@ let eval_var env = function
 
 let rec eval env = function
   | Var x -> eval_var env x
+  | ExtVar (cu,pos) -> !from_comp_unit cu pos
   | Apply (false,e1,e2) -> 
       let v1 = eval env e1 in
       let v2 = eval env e2 in

runtime/eval.mli

@@ -20,9 +20,11 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
 
 module L : sig
   open Lambda
+  val from_comp_unit: (Types.CompUnit.t -> int -> t) ref
   val dump: Format.formatter -> unit
   val push: Value.t -> unit
   val var: var_loc -> t
   val eval: code_item -> unit
   val expr: code_item -> t
+  val comp_unit: unit -> t array
 end

types/intervals.ml

@@ -46,7 +46,7 @@ let dump ppf _ = Format.fprintf ppf "<Intervals.t>"
 
 let rec check = function
   | []
-  | [ Any ] | [ Right _ ] | [ Left _ ] -> ()
+  | [ Any ] | [ Right _ ] | [ Left _ ] | [ Bounded _ ] -> ()
   | (Left i | Bounded (_,i)) :: ((Bounded (j,_) | (Right j)) :: _ as rem) ->
       assert (V.compare i j < 0);
       check rem

types/types.ml

@@ -16,6 +16,42 @@ let (<>) : int -> int -> bool = (<>)
 let compare = 1
 
 
+module CompUnit = struct   
+  include Pool.Make(Utf8)
+  module Tbl = Inttbl
+
+  let pervasives = mk (U.mk "Pervasives") 
+
+  let close_serialize_ref = ref (fun () -> assert false)
+
+  let depend = Inttbl.create ()
+
+  let serialize t cu =
+    if cu != pervasives then Inttbl.add depend cu ();
+    serialize t cu
+
+  let close_serialize () =