[r2004-06-28 03:27:16 by afrisch] Call OCaml functions

Original author: afrisch
Date: 2004-06-28 03:27:17+00:00

Makefile.distrib

@@ -154,6 +154,7 @@ OBJECTS = \
  \
  compile/lambda.cmo \
  runtime/value.cmo \
+ types/externals.cmo \
  \
  schema/schema_types.cmo \
  schema/schema_xml.cmo \

cdo2cmo/cdml.ml

@@ -8,11 +8,10 @@ type 'a ml2cd = 'a -> Value.t
 
 let initialize modname =
   let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 modname ) in
-  (try Librarian.import cu;
-   with Librarian.NoImplementation _ -> 
-     failwith ("Cdml: no implementation found for CDuce module " ^ modname));
-  Librarian.run cu;
-  cu
+  try Librarian.import cu; cu
+  with Librarian.NoImplementation _ -> 
+    failwith ("Cdml: no implementation found for CDuce module " ^ modname)
+
 
 let identity x = x
 

compile/compile.ml

@@ -17,9 +17,9 @@ let dump ppf env =
     env.vars
 
 
-let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
-let empty_toplevel = mk None
-let empty x = mk (Some x)
+let mk cu g = { cu = cu; vars = Env.empty; stack_size = 0; global_size = g }
+let empty_toplevel = mk None 0
+let empty x g = mk (Some x) g
 
 
 let serialize s env =
@@ -45,7 +45,7 @@ let find x env =
 
 let find_slot x env =
   match find x env with
-    | Lambda.Ext (_,slot) -> slot
+    | Ext (_,slot) -> slot
     | _ -> assert false
  
 
@@ -82,6 +82,10 @@ and compile_aux env tail = function
   | Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
   | Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
   | Typed.Ref (e,t) ->  Ref (compile env tail e, t)
+  | Typed.External (t,i) -> 
+      (match env.cu with
+	 | Some cu -> Var (Ext (cu,i))
+	 | None -> failwith "Cannot compile externals in the toplevel")
 
 and compile_abstr env a =
   let fun_env = 

compile/compile.mli

@@ -7,7 +7,9 @@ val from_comp_unit: (Types.CompUnit.t -> env) ref
 
 val dump: Format.formatter -> env -> unit
 
-val empty : Types.CompUnit.t -> env
+val empty : Types.CompUnit.t -> int -> env
+  (* integer: number of already allocated globals *)
+
 val empty_toplevel : env
 val serialize: env Serialize.Put.f
 val deserialize: env Serialize.Get.f

depend

@@ -78,6 +78,8 @@ runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
 runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
     misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
     misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi 
+types/externals.cmo: misc/custom.cmo types/externals.cmi 
+types/externals.cmx: misc/custom.cmx types/externals.cmi 
 schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi schema/schema_types.cmi 
 schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
@@ -129,15 +131,15 @@ parser/ast.cmx: types/builtin_defs.cmx types/chars.cmx types/ident.cmx \
     types/intervals.cmx parser/location.cmx misc/ns.cmx \
     schema/schema_types.cmx types/sequence.cmx types/types.cmx 
 parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
-    misc/encodings.cmi types/ident.cmo types/intervals.cmi \
-    parser/location.cmi misc/ns.cmi schema/schema_parser.cmi \
-    types/sequence.cmi types/types.cmi parser/ulexer.cmi parser/url.cmi \
-    parser/parser.cmi 
+    misc/encodings.cmi types/externals.cmi types/ident.cmo \
+    types/intervals.cmi parser/location.cmi misc/ns.cmi \
+    schema/schema_parser.cmi types/sequence.cmi types/types.cmi \
+    parser/ulexer.cmi parser/url.cmi parser/parser.cmi 
 parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
-    misc/encodings.cmx types/ident.cmx types/intervals.cmx \
-    parser/location.cmx misc/ns.cmx schema/schema_parser.cmx \
-    types/sequence.cmx types/types.cmx parser/ulexer.cmx parser/url.cmx \
-    parser/parser.cmi 
+    misc/encodings.cmx types/externals.cmx types/ident.cmx \
+    types/intervals.cmx parser/location.cmx misc/ns.cmx \
+    schema/schema_parser.cmx types/sequence.cmx types/types.cmx \
+    parser/ulexer.cmx parser/url.cmx parser/parser.cmi 
 typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
     schema/schema_types.cmi types/types.cmi 
 typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
@@ -293,6 +295,7 @@ types/builtin_defs.cmi: types/atoms.cmi types/ident.cmo types/types.cmi
 runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
     types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
     types/types.cmi 
+types/externals.cmi: types/types.cmi 
 schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi 
 schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi 

driver/librarian.ml

@@ -165,7 +165,7 @@ let rec compile verbose name id src =
     Compile.comp_unit 
       ?show
       Builtin.env
-      (Compile.empty id)
+      (Compile.empty id (Externals.nb_externals ()))
       p
   in
   let stub,types = !stub_ml name ty_env c_env in
@@ -246,9 +246,8 @@ let () =
   Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
   Eval.set_global := (fun cu i v -> import cu;
 			let cu = load cu in
-			match cu.status with
-			  | `Evaluating -> cu.vals.(i) <- v
-			  | _ -> assert false);;
+			cu.vals.(i) <- v)
+
     
 
 let registered_types cu = (load cu).types

ocamliface/mlstub.ml

@@ -398,6 +398,8 @@ let global_transl () =
 
 let err_ppf = Format.err_formatter
 
+let exts = ref []
+
 let check_value ty_env c_env (s,caml_t,t) =
   (* Find the type for the value in the CDuce module *)
   let id = Id.mk (U.mk s) in
@@ -436,20 +438,31 @@ let check_value ty_env c_env (s,caml_t,t) =
 
 let stub name ty_env c_env values =
   let items = List.map (check_value ty_env c_env) values in
+  let exts = 
+    List.map 
+      (fun (s,i,t) ->
+	 let c = to_cd <:expr< $lid:s$ >> t in
+	 <:str_item< Eval.set_slot cu $int:string_of_int i$ $c$ >>
+      ) !exts in
+
+
   let g = global_transl () in
-  
 
   (* open Cdml
      open CDuce_all
      let cu = Cdml.initialize <modname>
      let rec <global translation functions>
+     <fills external slots>
+     <run the unit>
      let <stubs for values>
   *)
 
   [ <:str_item< open Cdml >>;
     <:str_item< open CDuce_all >>;
     <:str_item< value cu = Cdml.initialize $str: String.escaped name$ >>;
-    <:str_item< value types = Librarian.registered_types cu >>
+    <:str_item< value types = Librarian.registered_types cu >>;
+    <:str_item< declare $list:exts$ end >>;
+    <:str_item< Librarian.run cu >>
   ] @
   (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
   [ <:str_item< value $list:items$ >> ]
@@ -457,13 +470,27 @@ let stub name ty_env c_env values =
 
 
 let () =
-  Librarian.stub_ml := fun cu ty_env c_env ->
-    try
-      let name = String.capitalize cu in
-      let (prolog, values) = Mltypes.read_cmi name 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)
-      | Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||]
+  Librarian.stub_ml := 
+  (fun cu ty_env c_env ->
+     try
+       let name = String.capitalize cu in
+       let (prolog, values) = Mltypes.read_cmi name 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)
+       | Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||]
+  );
+
+  Externals.register_external :=
+  (fun s i ->
+     let t = 
+       try Mltypes.find_value s 
+       with Not_found ->
+	 Printf.eprintf "Cannot resolve the external symbol %s\n" s;
+	 exit 1
+     in
+     exts := (s, i, t) :: !exts;
+     fun () -> Types.descr (typ t)
+  )

ocamliface/mlstub.mli

-(* nothing *)
+
+

ocamliface/mltypes.ml

@@ -178,3 +178,15 @@ let read_cmi name =
   (Buffer.contents buf, !values)
 
 let print_ocaml = Printtyp.type_expr
+
+
+let rec dump_li = function
+  | Longident.Lident s -> print_endline s
+  | Longident.Ldot (li,s) -> dump_li li; print_endline s
+  | _ -> assert false
+
+let find_value v =
+  Config.load_path := Config.standard_library :: !Librarian.obj_path;
+  let li = Longident.parse v in
+  let (p,vd) = Env.lookup_value li Env.initial in
+  unfold vd.val_type

ocamliface/mltypes.mli

@@ -20,3 +20,6 @@ val read_cmi: string -> string * (string * Types.type_expr * t) list
 
 val print : Format.formatter -> t -> unit
 val print_ocaml : Format.formatter -> Types.type_expr -> unit
+
+
+val find_value: string -> t

parser/ast.ml

@@ -72,6 +72,7 @@ and pexpr =
   | Forget of pexpr * ppat    
   | Op of string * pexpr list
   | Ref of pexpr * ppat
+  | External of (unit -> Types.t) * int
 
 
 

parser/parser.ml

@@ -193,7 +193,7 @@ EXTEND
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
         | "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
-	| "not" | "as" | "where"
+	| "not" | "as" | "where" | "external"
 	]
 	-> a
     ]
@@ -217,6 +217,9 @@ EXTEND
         exp loc (Validate (e, kind, schema, typ))
     | "fun"; (f,a,b) = fun_decl ->
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
+    | "external"; s = STRING2 ->
+	let (t,i) = Externals.parse s in
+	exp loc (External (t,i))
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (Match (e1,[p,e2]))
     | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->

runtime/eval.ml

@@ -65,6 +65,7 @@ let get_global = ref (fun cu pos -> assert false)
 let set_global = 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 eval_var env = function
   | Env i -> env.(i)

runtime/eval.mli

@@ -9,6 +9,7 @@ val get_global: (Types.CompUnit.t -> int -> t) ref
 val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
 
 val get_slot : Types.CompUnit.t -> int -> t
+val set_slot : Types.CompUnit.t -> int -> t -> unit
 
 val dump: Format.formatter -> unit
 val push: Value.t -> unit

tests/ocaml/a.cd

@@ -14,3 +14,10 @@ let map_complex (f : (Float,Float)->Float)(c : { x = Float; y = Float })
 
 
 let pp (x : Any) : Latin1 = string_of x
+
+
+let exists = external "Sys.file_exists"
+
+let i = 1
+
+let home = external "Sys.getenv" "HOME"

tests/ocaml/a.mli

@@ -13,3 +13,9 @@ val map_complex : (float * float -> float) -> complex -> float
 
 type t = A of t | B of t * t | C of int
 val pp : t -> string
+
+val i : int
+
+val exists : string -> bool
+
+val home : string

tests/ocaml/b.ml

+print_int A.i;;
 print_endline (A.f Char.uppercase "Abc");;
 print_endline (A.pp (A.A (A.C 2)));;
+print_endline A.home;;
+print_newline ();;

typing/typed.ml

@@ -52,6 +52,7 @@ and  texpr' =
   | UnaryOp of int * texpr
   | BinaryOp of int * texpr * texpr
   | Ref of texpr * ttyp
+  | External of Types.t * int
 
 and abstr = { 
   fun_name : id option; 

typing/typer.ml

@@ -939,6 +939,8 @@ let rec expr env loc = function
   | Ref (e,t) ->
       let (fv,e) = expr env loc e and t = typ env t in
       exp loc fv (Typed.Ref (e,t))
+  | External (t,i) ->
+      exp loc Fv.empty (Typed.External (t (),i))
 	      
   and branches env b = 
     let fv = ref Fv.empty in
@@ -1149,6 +1151,9 @@ and type_check' loc env e constr precise = match e with
       ignore (type_check env e (Types.descr t) false);
       verify loc (Builtin_defs.ref_type t) constr
 
+  | External (t,i) ->
+      verify loc t constr
+
 and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
   let rects = Types.Product.normal ~kind constr in
   if Types.Product.is_empty rects then