Commit eb92159a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-06-28 12:37:21 by afrisch] Calling polymorphic OCaml functions

Original author: afrisch
Date: 2004-06-28 12:37:21+00:00
parent f119be97
......@@ -167,7 +167,7 @@ let rec compile verbose name id src =
Compile.comp_unit
?show
Builtin.env
(Compile.empty id (Externals.nb_externals ()))
(Compile.empty id (Externals.nb ()))
p
in
let stub,types = !stub_ml name ty_env c_env in
......
......@@ -18,6 +18,8 @@ module IntHash =
(* Compute CDuce type *)
let vars = ref [||]
let memo_typ = IntHash.create 13
let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
......@@ -49,6 +51,7 @@ and typ_descr = function
| Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
| Builtin ("CDuce_all.Value.t", []) -> Types.any
| Builtin ("unit", []) -> Sequence.nil_type
| Var i -> Types.descr (!vars).(i)
| _ -> assert false
and pvariant = function
......@@ -248,6 +251,7 @@ and to_cd_descr e = function
| Builtin ("CDuce_all.Value.t", []) -> e
| Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
| Var _ -> e
| _ -> assert false
and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
......@@ -365,6 +369,7 @@ and to_ml_descr e = function
<:expr< Pervasives.ref $to_ml e t$ >>
| Builtin ("CDuce_all.Value.t", []) -> e
| Builtin ("unit", []) -> <:expr< ignore $e$ >>
| Var _ -> e
| _ -> assert false
and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars
......@@ -496,14 +501,26 @@ let () =
with Mltypes.Error s -> raise (Location.Generic s)
);
Externals.register_external :=
(fun s i ->
let t =
Externals.resolve :=
(fun i s args ->
let (t,n) =
try Mltypes.find_value s
with Not_found ->
Printf.eprintf "Cannot resolve the external symbol %s\n" s;
exit 1
in
let m = List.length args in
if n <> m then
(
Printf.eprintf "Wrong arity for external symbol %s (real arity = %i; given = %i)\n" s n m;
exit 1
);
exts := (s, i, t) :: !exts;
fun () -> Types.descr (typ t)
vars := Array.of_list args;
let cdt = Types.descr (typ t) in
(* Format.fprintf Format.std_formatter "Instance: %a@."
Types.Print.print cdt; *)
vars := [| |];
cdt
)
......@@ -18,6 +18,7 @@ and def =
| Record of (string * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
module IntMap =
Map.Make(struct type t = int let compare : t -> t -> int = compare end)
......@@ -53,6 +54,7 @@ and print_def ppf = function
| Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l
| Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
| Abstract s -> Format.fprintf ppf "%s" s
| Var i -> Format.fprintf ppf "'a%i" i
and print_palt ppf = function
......@@ -80,6 +82,15 @@ let builtins =
List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit" ]
let vars = ref []
let get_var id =
try List.assq id !vars
with Not_found ->
let i = List.length !vars in
vars := (id,i) :: !vars;
i
let rec unfold seen constrs ty =
try
let t = IntMap.find ty.id seen in
......@@ -103,7 +114,9 @@ let rec unfold seen constrs ty =
| _ -> assert false)
rd.row_fields in
PVariant fields
| Tvar -> failwith "Polymorphic value"
| Tvar ->
Var (get_var ty.id)
(* failwith "Polymorphic value"*)
| Tconstr (p,args,_) ->
let args = List.map loop args in
let pn = Path.name p in
......@@ -147,7 +160,12 @@ let rec unfold seen constrs ty =
);
slot
let unfold = unfold IntMap.empty StringMap.empty
let unfold ty =
vars := [];
let t = unfold IntMap.empty StringMap.empty ty in
let n = List.length !vars in
vars := [];
(t,n)
(* Reading .cmi *)
......@@ -165,7 +183,9 @@ let read_cmi name =
List.iter
(function
| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
values := (Ident.name id, t, unfold t) :: !values
let (unf,n) = unfold t in
if n !=0 then unsupported "polymorphic value";
values := (Ident.name id, t, unf) :: !values
| Tsig_type (id,t) ->
Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
| Tsig_value (_,_) -> unsupported "external value"
......
......@@ -14,6 +14,7 @@ and def =
| Record of (string * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
val read_cmi: string -> string * (string * Types.type_expr * t) list
......@@ -22,4 +23,4 @@ val print : Format.formatter -> t -> unit
val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t
val find_value: string -> t * int
......@@ -72,7 +72,7 @@ and pexpr =
| Forget of pexpr * ppat
| Op of string * pexpr list
| Ref of pexpr * ppat
| External of (unit -> Types.t) * int
| External of string * ppat list * int
......
......@@ -218,8 +218,9 @@ EXTEND
| "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))
exp loc (External (s,[],Externals.alloc ()))
| "external"; "{"; s = STRING2; pl = LIST0 pat; "}" ->
exp loc (External (s,pl,Externals.alloc ()))
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......
......@@ -172,7 +172,7 @@ let normalize = function
| String_latin1 (i,j,s,q) -> normalize_string_latin1 i j s q
| String_utf8 (i,j,s,q) -> normalize_string_utf8 i j s q
| Concat (_,_) as v -> eval_lazy_concat v; v
| v -> assert false
| v -> v
......
......@@ -28,4 +28,9 @@ let str_len = external "String.length"
let _ = unix_write stdin home 0 (str_len home)
let [] = external "Unix.sleep" 3
let [] = external "Unix.sleep" 1
let listmap = external { "List.map" Int Int }
let lst = listmap (fun (x : Int) : Int = x * 2) [ 10 20 30 ] in
print (string_of lst)
......@@ -939,8 +939,10 @@ 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))
| External (s,args,i) ->
let args = List.map (typ env) args in
let t = !Externals.resolve i s args in
exp loc Fv.empty (Typed.External (t,i))
and branches env b =
let fv = ref Fv.empty in
......
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