Commit 88850462 authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2004-06-28 03:27:17+00:00
parent 7765befb
......@@ -154,6 +154,7 @@ OBJECTS = \
\
compile/lambda.cmo \
runtime/value.cmo \
types/externals.cmo \
\
schema/schema_types.cmo \
schema/schema_xml.cmo \
......
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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)
)
......@@ -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
......@@ -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
......@@ -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
......
......@@ -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" ->
......
......@@ -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)
......
......@@ -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
......
......@@ -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"
......@@ -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
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 ();;
......@@ -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;
......
......@@ -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
......
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