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

Original author: afrisch
Date: 2004-06-28 12:37:21+00:00

driver/librarian.ml

@@ -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

ocamliface/mlstub.ml

@@ -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
   )

ocamliface/mltypes.ml

@@ -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"

ocamliface/mltypes.mli

@@ -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

parser/ast.ml

@@ -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
 
 
 

parser/parser.ml

@@ -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" ->

runtime/value.ml

@@ -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
 
 
 

tests/ocaml/a.cd

@@ -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)

typing/typer.ml

@@ -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