[r2005-03-04 12:11:52 by afrisch] cduce_mktop

Original author: afrisch
Date: 2005-03-04 12:11:54+00:00

META.in

+version="%VER%"
+requires="%REQ% camlp4.gramlib"
+description="Runtime support for CDuce"
+archive(byte)="cduce_lib.cma"
+archive(native)="cduce_lib.cmxa"

Makefile.distrib

 include Makefile.conf
 VERSION = 0.2.3b1
 
-all: cduce dtd2cduce validate cdo2ml cduce_lib.cma
+all: cduce dtd2cduce cduce_validate cdo2ml mlcduce_wrapper cduce_lib.cma
 ifeq ($(NATIVE),true)
 all: cduce_lib.cmxa
 endif
@@ -87,16 +87,14 @@ install_bin:
 	@echo "Install binaries"
 	$(HIDE)mkdir -p $(BINDIR)
 	$(HIDE)$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) \
-                         validate$(EXE) cdo2ml$(EXE) $(BINDIR)/
+                         cduce_validate$(EXE) cdo2ml$(EXE) \
+			mlcduce_wrapper$(EXE) \
+			cduce_mktop $(BINDIR)/
 	
 
 install_lib:
 	@echo "Build META"
-	$(HIDE)echo 'version="$(VERSION)"' > META
-	$(HIDE)echo 'requires="$(PACKAGES) camlp4.gramlib"' >> META
-	$(HIDE)echo 'description="Runtime support for CDuce"' >> META
-	$(HIDE)echo 'archive(byte)="cduce_lib.cma"' >> META
-	$(HIDE)echo 'archive(native)="cduce_lib.cmxa"' >> META
+	$(HIDE)(sed "s/%REQ%/$(PACKAGES)/" < META.in | sed "s/%VER%/$(VERSION)/" > META)
 	$(HIDE)-$(OCAMLFIND) remove cduce
 	$(HIDE)-$(OCAMLFIND) install cduce META \
          cduce_lib.cmi $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) \
@@ -104,9 +102,10 @@ install_lib:
 
 uninstall:
 	rm -f $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) \
-	  $(BINDIR)/validate$(EXE) $(BINDIR)/cdo2ml$(EXE)
+	  $(BINDIR)/cduce_validate$(EXE) $(BINDIR)/cdo2ml$(EXE) \
+	  $(BINDIR)/mlcduce_wrapper$(EXE) $(BINDIR)/cduce_mktop
 	rm -f $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 \
-	  $(MANDIR)/man1/validate.1 $(MANDIR)/man1/cdo2ml.1
+	  $(MANDIR)/man1/cduce_validate.1 $(MANDIR)/man1/cdo2ml.1
 	rm -Rf $(DOCDIR)
 	ocamlfind remove cduce
 
@@ -114,7 +113,7 @@ help:
 	@echo "GOALS"
 	@echo "  cduce : compiles the CDuce command line interpreter"
 	@echo "  dtd2cduce : compiles the dtd2cduce tools"
-	@echo "  validate : compiles the schema validation tool"
+	@echo "  cduce_validate : compiles the schema validation tool"
 	@echo "  doc : build the documentation"
 	@echo "  all : build binaries and libraries"
 	@echo "  install : install binaries, man pages, documentation"
@@ -212,7 +211,8 @@ OBJECTS += $(CQL_OBJECTS)
 
 VALIDATE_OBJECTS := $(shell for o in $(OBJECTS); do echo $$o; if [ "$$o" = "schema/schema_parser.cmo" ]; then exit 0; fi; done)	# all objects until schema_parser.cmo
 
-CDUCE = $(OBJECTS) $(CQL_OBJECTS_RUN) driver/run.cmo 
+OBJECTS += $(CQL_OBJECTS_RUN) driver/run.cmo
+CDUCE = $(OBJECTS) driver/start.cmo 
 DTD2CDUCE = tools/dtd2cduce.cmo
 
 ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \
@@ -255,10 +255,14 @@ dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
 	@echo "Build $@"
 	$(HIDE)$(LINK) $(INCLUDES) -o $@ $^
 
-validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
+cduce_validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
 	@echo "Build $@"
 	$(HIDE)$(LINK) $(INCLUDES) -o $@ $^
 
+mlcduce_wrapper: $(OBJECTS:.cmo=.$(EXTENSION)) ocamliface/mlcduce_wrapper.ml
+	@echo "Build $@"
+	$(HIDE)$(LINK) $(INCLUDES) -o $@ odyl.cma camlp4.cma pr_o.cmo $^ $(EXTRA_LINK_OPTS)
+
 cdo2ml: ocamliface/cdo2ml.ml
 	@echo "Build $@"
 	$(HIDE)ocamlc -o $@ -pp camlp4o -I +camlp4 odyl.cma camlp4.cma pr_o.cmo $^
@@ -277,7 +281,7 @@ clean:
 	rm -f `find . -name "*~"`
 	rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~ META
 	rm -f cduce$(EXE) ocamlprof.dump
-	rm -f dtd2cduce$(EXE) webiface$(EXE) validate$(EXE) cdo2ml$(EXE) evaluator$(EXE)
+	rm -f dtd2cduce$(EXE) webiface$(EXE) cduce_validate$(EXE) cdo2ml$(EXE) evaluator$(EXE)
 	rm -Rf prepro package
 	rm -f web/www/*.html web/*~
 	rm -f web/*.cdo

cduce_mktop

+#!/bin/sh
+
+TARG=$1
+PRIMS=$2
+
+if [ "${TARG}" = "" ] || [ "${PRIMS}" = "" ]; then
+  echo "Usage: cduce_mktop <target> <primitive file>"
+  exit 2
+fi
+
+exec ocamlfind ocamlc -package cduce -o $TARG -linkpkg -pp mlcduce_wrapper -impl $PRIMS

compile/compile.ml

@@ -83,10 +83,12 @@ and compile_aux env tail = function
   | Typed.Dot (e,l) -> Dot (compile env tail e, l)
   | Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
   | Typed.Ref (e,t) ->  Ref (compile env tail e, t)
-  | Typed.External (t,i) -> 
+  | Typed.External (t,`Ext i) -> 
       (match env.cu with
 	 | Some cu -> Var (External (cu,i))
 	 | None -> failwith "Cannot compile externals in the toplevel")
+  | Typed.External (t,`Builtin s) -> 
+      Var (Builtin s)
   | Typed.Op (op,_,args) -> 
       let rec aux = function
 	| [arg] -> [ compile env tail arg ]
@@ -110,7 +112,7 @@ and compile_abstr env a =
 	       p::slots,
 	       succ nb_slots,
 	       Env.add x (Env nb_slots) fun_env;
-	   | Global _ | Ext _ | External _ as p -> 
+	   | Global _ | Ext _ | External _ | Builtin _ as p -> 
 	       slots,
 	       nb_slots,
 	       Env.add x p fun_env

compile/lambda.ml

@@ -6,6 +6,7 @@ type var_loc =
   | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
   | External of Types.CompUnit.t * int 
       (* If pos < 0, the first arg is the value *)
+  | Builtin of string
   | Global of int (* Only for the toplevel *)
   | Dummy
 
@@ -14,6 +15,7 @@ let print_var_loc ppf = function
   | Env i -> Format.fprintf ppf "Env %i" i
   | Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
   | External (cu,i) -> Format.fprintf ppf "External (_,%i)" i
+  | Builtin s -> Format.fprintf ppf "Builtin (%s,_)" s
   | Global i -> Format.fprintf ppf "Global %i" i
   | Dummy -> Format.fprintf ppf "Dummy"
 
@@ -123,14 +125,18 @@ module Put = struct
 	Types.CompUnit.serialize s cu;
 	int s i
     | External (cu,i) ->
+	assert (i >= 0);
 	bits 3 s 2;
 	Types.CompUnit.serialize s cu;
 	int s i
-    | Env i ->
+    | Builtin b ->
 	bits 3 s 3;
+	Serialize.Put.string s b
+    | Env i ->
+	bits 3 s 4;
 	int s i
     | Dummy ->
-	bits 3 s 4
+	bits 3 s 5
     | Global _ -> assert false
 	
   let rec expr s = function
@@ -258,8 +264,11 @@ module Get = struct
 	  let cu = Types.CompUnit.deserialize s in
 	  let pos = int s in
 	  External (cu,pos)
-      | 3 -> Env (int s)
-      | 4 -> Dummy
+      | 3 ->
+	  let s = Serialize.Get.string s in
+	  Builtin s
+      | 4 -> Env (int s)
+      | 5 -> Dummy
       | _ -> assert false
 
   let rec expr s =

compile/lambda.mli

@@ -6,6 +6,7 @@ type var_loc =
   | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
   | External of Types.CompUnit.t * int 
       (* If pos < 0, the first arg is the value *)
+  | Builtin of string
   | Global of int (* Only for the toplevel *)
   | Dummy
 

compile/operators.ml

@@ -46,7 +46,7 @@ let register_cst op t v =
 let register_fun op dom codom eval =
   register_cst op
     (Types.arrow (Types.cons dom) (Types.cons codom))
-    (Value.Abstraction ([(dom,codom)],eval))
+    (Value.Abstraction (Some [(dom,codom)],eval))
 
 let register_op op ?(expect=Types.any) typ eval =
   register_unary op 

driver/librarian.ml

@@ -182,7 +182,7 @@ let rec compile verbose name id src =
       p
   in
   let stub,types = !stub_ml name ty_env c_env in
-  let ext = Externals.nb () > 0 in
+  let ext = Externals.has () in
   let cu = mk (cu,types,ext) in
   cu.stub <- stub;
   C.Tbl.add tbl id cu;
@@ -279,16 +279,30 @@ let import_check id chk = ignore (load_check id chk)
 let import_and_run id = import id; run id
 
 let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
+let static_externals = Hashtbl.create 17
+let register_static_external n v = 
+  print_endline ("Builtin " ^ n);
+  Hashtbl.add static_externals n v
 
 let () =
   Typer.from_comp_unit := (fun cu -> (load cu).typing);
   Typer.has_comp_unit := has_obj;
+  Typer.has_static_external :=  Hashtbl.mem static_externals;
   Compile.from_comp_unit := (fun cu -> (load cu).compile);
   Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
   Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
-  Eval.get_external := (fun cu i -> (load cu).exts.(i))
+  Eval.get_external := (fun cu i -> (load cu).exts.(i));
+  Eval.get_builtin := Hashtbl.find static_externals
     
 
 let set_externals cu a = (load cu).exts <- a
 
 let registered_types cu = (load cu).types
+
+
+let pack_types typs =
+  Serialize.Put.run (Serialize.Put.array Types.serialize) typs
+let unpack_types typs =
+  Serialize.Get.run (Serialize.Get.array Types.deserialize) typs
+
+

driver/librarian.mli

@@ -27,3 +27,9 @@ val set_externals: Types.CompUnit.t -> Value.t array -> unit
 type stub_ml
 val stub_ml : (string -> Typer.t -> Compile.env -> 
 		 stub_ml option * Types.t array) ref
+
+val pack_types: Types.t array -> string
+val unpack_types: string -> Types.t array
+
+val register_static_external: string -> Value.t -> unit
+

driver/run.ml

@@ -181,10 +181,11 @@ let save () =
     | None -> ()
 
 let main () = 
+  at_exit (fun () -> Stats.dump Format.std_formatter);
   Location.set_viewport (Html.create false);
   match mode () with
     | `Toplevel args ->
-	Config.inhibit "ocaml";
+(*	Config.inhibit "ocaml"; *)
 	Config.init_all ();
 	Builtin.argv := argv args;
 	restore ();
@@ -202,6 +203,4 @@ let main () =
 	Builtin.argv := argv args;
 	Cduce.run f
 	 
-let () = 
-  at_exit (fun () -> Stats.dump Format.std_formatter);
-  main ()
+

ocamliface/mlcduce_wrapper.ml

+let loc = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+let usage =
+"Usage: mlcduce_wrapper <primitive file>
+" 
+
+let err s = prerr_endline s; prerr_endline usage; exit 1
+
+let () =
+  if Array.length Sys.argv != 2 then err "";
+  let fn = Sys.argv.(1) in
+  let ic = 
+    try open_in fn
+    with Sys_error s -> err s in
+  let v = ref [] in
+  (try while true do 
+     let s = input_line ic in
+     if s = "" then raise End_of_file;
+     match s.[0] with
+       | 'A'..'Z' -> v := s :: !v 
+       | _ -> err "Names must start with a capitalized letter"
+   done 
+   with End_of_file -> ());
+  let s = Mlstub.gen_wrapper !v in
+  !Pcaml.print_implem [ s,loc ]
+

ocamliface/mlstub.ml

@@ -113,11 +113,14 @@ let protect e f =
 
 (* Registered types *)
 
+let gen_types = ref true
+
 module HashTypes = Hashtbl.Make(Types)
 let registered_types = HashTypes.create 13
 let nb_registered_types = ref 0
 
 let register_type t =
+  assert(!gen_types);
   let n =
     try HashTypes.find registered_types t
     with Not_found ->
@@ -200,9 +203,13 @@ and to_cd_descr e = function
 	 let arg = to_ml <:expr< $lid:x$ >> t in
 	 let res = to_cd (call_lab y l arg) s in
 	 let abs = <:expr< fun $lid:x$ -> $res$ >> in
-	 let tt = register_type (Types.descr (typ t)) in
-	 let ss = register_type (Types.descr (typ s)) in
-	 <:expr< Value.Abstraction ([($tt$,$ss$)],$abs$) >>
+	 let iface =
+	   if !gen_types then
+	     let tt = register_type (Types.descr (typ t)) in
+	     let ss = register_type (Types.descr (typ s)) in
+	     <:expr< Some [($tt$,$ss$)] >>
+	   else <:expr< None >> in
+	 <:expr< Value.Abstraction ($iface$,$abs$) >>
       )
   | Tuple tl -> 
       (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
@@ -230,7 +237,13 @@ and to_cd_descr e = function
       let cases = 
 	List.map
 	  (function 
-	     | (lab,[]) -> <:patt< $lid:p^lab$ >>, atom_ascii lab
+	     | (lab,[]) ->
+		 let pat = match lab with (* Stupid Camlp4 *)
+		    | "true" -> <:patt< True >>
+		    | "false" -> <:patt< False >>
+		    | lab -> <:patt< $lid:p^lab$ >>
+		 in
+		 pat, atom_ascii lab
 	     | (lab,tl) -> 
 		 let vars = mk_vars tl in
 		 <:patt< $lid:p^lab$ $pat_tuple vars$ >>,
@@ -249,7 +262,7 @@ and to_cd_descr e = function
 	     l
 	 in
 	 <:expr< Value.record $list_lit l$ >>)
-      
+
   | Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
   | Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
   | Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
@@ -265,7 +278,11 @@ and to_cd_descr e = function
       protect e 
       (fun e ->
 	 let y = mk_var () in
-	 let tt = register_type (Types.descr (typ t)) in
+	 let tt = if !gen_types then 
+	   let t = register_type (Types.descr (typ t)) in
+	   <:expr< Some $t$ >> 
+	 else
+	   <:expr< None >> in
 	 let get_x = <:expr< $e$.val >> in
 	 let get = <:expr< fun () -> $to_cd get_x t$ >> in
 	 let tr_y = to_ml <:expr< $lid:y$ >> t in
@@ -475,6 +492,7 @@ let check_value ty_env c_env (s,caml_t,t) =
   <:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
 
 let stub name ty_env c_env values =
+  gen_types := true;
   let items = List.map (check_value ty_env c_env) values in
 
   let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
@@ -502,8 +520,7 @@ let stub name ty_env c_env values =
     [ <:str_item< open Cduce_lib >>;
       <:str_item< Config.init_all () >>;
       <:str_item< value types = Librarian.registered_types cu >> ] @
-    (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
-    [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
+    (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @    [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
     <:str_item< Librarian.run cu >> ] @
     (if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
 
@@ -514,44 +531,110 @@ let stub name ty_env c_env values =
 
   <:patt< ($list:items_pat$) >>, m, items_expr
 
+let stub_ml cu ty_env c_env = 
+  try
+    let name = String.capitalize cu in
+    let (prolog, values) = 
+      try Mltypes.read_cmi name
+      with Not_found ->  ("",[]) in
+    let code = stub cu ty_env c_env values in
+    Some (Obj.magic (prolog,code)),
+    get_registered_types ()
+  with Mltypes.Error s -> raise (Location.Generic s)
+
+
+let register b s args = 
+  try
+    let (t,n) = Mltypes.find_value s in
+    let m = List.length args in
+    if n <> m then
+      Location.raise_generic
+	(Printf.sprintf 
+	   "Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
+    let i = if b then
+      let i = List.length !exts in
+      exts := (s, t) :: !exts;
+      i
+    else
+      0 in
+    
+    vars := Array.of_list args;
+    let cdt = Types.descr (typ t) in
+    vars := [| |];
+    i,cdt
+  with Not_found -> 
+    Location.raise_generic
+      (Printf.sprintf "Cannot resolve ocaml external %s" s)
+
+(* Generation of wrappers *)
+
+let wrapper values =
+  gen_types := false;
+  let exts = List.rev_map 
+    (fun (s,t) -> 
+       let v = to_cd <:expr< $lid:s$ >> t in
+       <:str_item< 
+	 Librarian.register_static_external $str:String.escaped s$ $v$ >>)
+    values in
+  let g = global_transl () in
+
+  let m = if g = [] then exts else <:str_item< value rec $list:g$ >>::exts in
+  let m = [ <:str_item< open Cduce_lib >>;
+	    <:str_item< Config.init_all () >>] @ m @
+    [ <:str_item< Run.main () >> ] in
+
+  <:str_item< declare $list:m$ end >>
+
+
+let gen_wrapper vals =
+  try
+    let values = List.fold_left
+      (fun accu s ->
+	 try (s,fst (Mltypes.find_value s)) :: accu
+	 with Not_found ->
+	   let vals = 
+	     try Mltypes.load_cmi s
+	     with Not_found ->
+	       failwith ("Cannot resolve " ^ s)
+	   in
+	   vals @ accu
+      ) [] vals in
+
+    wrapper values
+  with Mltypes.Error s -> raise (Location.Generic s)
+
+
+(* Dynamic coercions *)
+
+
+(*
+let to_cd_dyn = function
+  | Link t -> to_cd_dyn e t
+  | Arrow (l,t,s) ->
+      let tt = Types.descr (typ t) in
+      let ss = Types.descr (typ s) in
+      let tf = to_ml_dyn t in
+      let sf = to_cd_dyn t in
+      (fun (f : Obj.repr) ->
+	 let f = (Obj.magic f : Obj.repr -> Obj.repr) in
+	 Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
+  | Tuple tl -> 
+      let fs = List.map to_cd_dyn tl in
+      (fun (x : Obj.repr) ->
+	 let x = (Obj.magic x : Obj.repr array) in
+	 let rec aux i = function
+	   | [] -> assert false
+	   | [f] -> f x.(i)
+	   | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
+	 aux 0 fs)
+*)
+
 
 let register () =
   Typer.has_ocaml_unit :=
     (fun cu -> Mltypes.has_cmi (U.get_str cu));
-  Librarian.stub_ml := 
-  (fun cu ty_env c_env ->
-     try
-       let name = String.capitalize cu in
-       let (prolog, values) = 
-	 try Mltypes.read_cmi name
-	 with Not_found ->  
-(* 	   Printf.eprintf "Warning: no caml interface\n"; *)
-	   ("",[]) in
-       let code = stub cu ty_env c_env values in
-       Some (Obj.magic (prolog,code)),
-       get_registered_types ()
-     with Mltypes.Error s -> raise (Location.Generic s)
-  );
-
-  Externals.register :=
-  (fun i s args ->
-     try
-       let (t,n) = Mltypes.find_value s in
-       let m = List.length args in
-       if n <> m then
-	 Location.raise_generic
-	   (Printf.sprintf 
-	      "Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
-       exts := (s, t) :: !exts;
-
-       vars := Array.of_list args;
-       let cdt = Types.descr (typ t) in
-       vars := [| |];
-       cdt
-     with Not_found -> 
-       Location.raise_generic
-         (Printf.sprintf "Cannot resolve ocaml external %s" s)
-  )
+  Librarian.stub_ml := stub_ml;
+  Externals.register := register
 
 let () =
   Config.register 

ocamliface/mlstub.mli

-
-
+val gen_wrapper: string list -> MLast.str_item

ocamliface/mltypes.ml

@@ -6,6 +6,8 @@ open Types
 
 (* Unfolding of OCaml types *)
 
+exception PolyAbstract of string
+
 let ocaml_env = ref Env.initial
 
 type t = { uid : int; mutable recurs : int; mutable def : def }
@@ -166,7 +168,7 @@ let rec unfold seen constrs ty =
 		   | Type_abstract, None ->
 		       (match args with
 			  | [] -> Abstract pn
-			  | _ -> failwith ("Polymorphic abstract type: " ^ pn))))
+			  | _ -> raise (PolyAbstract pn))))
        | _ -> failwith "Unsupported feature"
     );
     slot
@@ -188,6 +190,33 @@ let has_cmi name =
   try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
   with Not_found -> false
 
+let load_cmi name = 
+  Config.load_path := Config.standard_library :: !Librarian.obj_path;
+  let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
+  let sg = Env.read_signature name filename in
+  ocaml_env := Env.add_signature sg Env.initial;
+  let values = ref [] in
+  List.iter
+    (function
+       | Tsig_value (id, {val_type=t;val_kind=Val_reg|Val_prim _}) -> 
+	   let n = name ^ "." ^ (Ident.name id) in
+	   (try
+	     let (t,_) = unfold t in
+	     values := (name ^ "." ^ (Ident.name id), t) :: !values
+	   with PolyAbstract _ -> ())
+       | _ -> ()
+    ) sg;
+  !values
+
+let load_cmi name =
+  try load_cmi name
+  with Env.Error e ->
+    Env.report_error Format.str_formatter e;
+    let s = Format.flush_str_formatter () in
+    let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
+	      name s in
+    raise (Location.Generic s)
+
 let read_cmi name =
   Config.load_path := Config.standard_library :: !Librarian.obj_path;
   let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in

ocamliface/mltypes.mli

@@ -17,6 +17,11 @@ and def =
   | Var of int
 
 
+(* Load an external .cmi *)
+val has_cmi: string -> bool
+val load_cmi: string -> (string * t) list
+
+(* Load the .cmi corresponding to a CDuce compilation unit *)
 val read_cmi: string -> string * (string * Types.type_expr * t) list
 
 val print : Format.formatter -> t -> unit
@@ -25,4 +30,3 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
 
 val find_value: string -> t * int
 
-val has_cmi: string -> bool

parser/ast.ml

@@ -62,7 +62,7 @@ and pexpr =
   | Transform of pexpr * branches
   | Xtrans of pexpr * branches
   | Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
-  | Dot of pexpr * label
+  | Dot of pexpr * label * ppat list
   | RemoveField of pexpr * label
 
   (* Exceptions *)
@@ -73,7 +73,6 @@ and pexpr =
   | Forget of pexpr * ppat    
   | Check of pexpr * ppat
   | Ref of pexpr * ppat
-  | External of string * ppat list
 
 
 

parser/parser.ml

@@ -216,7 +216,7 @@ EXTEND
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
         | "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
-	| "not" | "as" | "where" | "external"
+	| "not" | "as" | "where"
 	]
 	-> a
     ]
@@ -240,10 +240,6 @@ EXTEND
         exp loc (Validate (e, schema, typ))
     | "fun"; (f,a,b) = fun_decl ->
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
-    | "external"; s = STRING2 ->
-	exp loc (External (s,[]))
-    | "external"; "{"; s = STRING2; pl = LIST0 pat; "}" ->
-	exp loc (External (s,pl))
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (Match (e1,[p,e2]))
     | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
@@ -260,7 +256,7 @@ EXTEND
     ]
     |
     [ e1 = expr; ":="; e2 = expr ->
-	exp loc (Apply (Dot (e1, U.mk "set"), e2))
+	exp loc (Apply (Dot (e1, U.mk "set", []), e2))
     ]
     | 
     [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr -> 
@@ -291,8 +287,10 @@ EXTEND
 	exp loc (Transform (e,[b]))
     ]
     |
-    [ e = expr;  "."; l = [IDENT | keyword ] -> 
-	exp loc (Dot (e, label l)) 
+    [ e = expr;  "."; l = [IDENT | keyword ];
+      tyargs = [ "with"; "{"; pl = LIST0 pat; "}" -> pl | -> [] ]
+      -> 
+	exp loc (Dot (e, label l,tyargs)) 
     ]  
     | [ 
       e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
@@ -328,7 +326,7 @@ EXTEND
 	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
     | a = IDENT -> exp loc (Var (U.mk a))
     | "!"; e = expr ->
-	exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
+	exp loc (Apply (Dot (e, U.mk "get", []), cst_nil))
     | i = INT -> exp loc (Integer (Intervals.V.mk i))
     | "`"; a = tag -> a
     | c = char -> exp loc (Char c)

query/query.ml

@@ -151,7 +151,7 @@ let rec string_of_pexpr x =
                       ^string_of_branches(b) ^ ")"
        | Xtrans(e,b) -> "(xtransform" ^string_of_pexpr e ^ " with"
                       ^string_of_branches(b) ^ ")"
-       | Dot(e1,_) -> "Dot(" ^ string_of_pexpr e1 ^",lbl)"
+       | Dot(e1,_,_) -> "Dot(" ^ string_of_pexpr e1 ^",lbl)"
        | RemoveField (e,l) -> "RF(" ^ string_of_pexpr e ^",lbl)"	      
        | Const (Types.Atom a) -> (match (Atoms.V.value a) with
 				 (_,utf) -> "`"^U.get_str utf )

query/query_parse.ml

@@ -63,8 +63,8 @@ EXTEND
         in exp loc (Transform (e,[t]))
      | e = expr; "//" ; p = pat -> (* projections sur tous les descendants *)
        let assign= 
-       exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set"),
-           (op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
+       exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set",[]),
+           (op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
        in let branche=Pair(Var id_dummy,cst_nil)
        in let branches= exp loc (Match(assign,[pat_nil,branche]))
        in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(None,U.mk "$$$")),p))),branches]))
@@ -73,7 +73,7 @@ EXTEND
        in exp loc(Match(rf,[mk loc(PatVar(None,U.mk"$stack")),
                exp loc(Match(xt,
 	          [mk loc(Internal Types.any),
-	          exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil))]))
+	          exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil))]))
 	       ]))   	      
      
      (* equivalent as:

runtime/eval.ml

@@ -88,6 +88,8 @@ let set_external = ref (fun cu pos -> assert false)
 let get_slot cu pos = !get_global cu pos
 let set_slot cu pos v = !set_global cu pos v
 
+let get_builtin = ref (fun _ -> assert false)
+
 let eval_var env = function
   | Env i -> env.(i)
   | Stack i -> !stack.(!frame + i) 
@@ -107,6 +109,8 @@ let eval_var env = function
 	Obj.set_field x 0 (Obj.repr v);
 	Obj.set_field x 1 (Obj.repr (-1));
 	v
+  | Builtin s ->
+      !get_builtin s
 
 let tag_op_resolved = Obj.tag (Obj.repr (OpResolved (Obj.repr 0, [])))