Commit 036cee4f authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Enable OCaml polymorphic primitives.

parent 643e56c7
......@@ -8,6 +8,7 @@ Stdlib.Filename
Stdlib.Float
Stdlib.Int32
Stdlib.Int64
Stdlib.List
Stdlib.Random
Stdlib.String
Stdlib.Sys
......@@ -3,7 +3,6 @@ open Cduce_types
open Ident
module U = Encodings.Utf8
(* let () = Stats.gettimeofday := Unix.gettimeofday *)
exception Escape of exn
......@@ -241,8 +240,12 @@ let directive ppf tenv cenv = function
| `Verbose -> silent := false
| `Builtins ->
let b = Librarian.get_builtins () in
Format.fprintf ppf "Embedded OCaml value: ";
List.iter (fun s -> Format.fprintf ppf "%s " s) b;
Format.fprintf ppf "Embedded OCaml values: ";
List.iter
(fun s ->
let t = Externals.typ s [] in
Format.fprintf ppf "%s : %a@\n" s Types.Print.print t)
b;
Format.fprintf ppf "@."
let print_id_opt ppf = function
......
......@@ -852,10 +852,24 @@ let stub_ml binary filename name ty_env c_env exts mk =
stub binary filename ty_env c_env exts values mk prolog
with Mltypes.Error s -> raise (Cduce_core.Cduce_loc.Generic s)
let mk_poly_vars n =
let rec loop i acc =
if i = n then
List.rev
(Var.Map.fold
(fun _ v acc -> v :: acc)
(Var.full_renaming (Var.Set.from_list acc))
[])
else loop (i + 1) (Var.mk ("a" ^ string_of_int i) :: acc)
in
List.map (fun x -> Types.(cons (var x))) (loop 0 [])
let register b s args =
try
let t, n = Mltypes.find_value s in
let m = List.length args in
let args = if m = 0 && n != 0 then mk_poly_vars n else args in
let m = List.length args in
if n <> m then
Cduce_core.Cduce_loc.raise_generic
(Printf.sprintf
......@@ -891,7 +905,10 @@ let wrapper values =
let g =
match global_transl () with [] -> ML.[ bind (pany ()) unit ] | g -> g
in
let g =
ML.(bind (pat_var "___dummy") (fun_ "x" (sapply "___dummy" [ var "x" ])))
:: g
in
ML.(
fun_unit
(seq
......
......@@ -75,7 +75,7 @@ let rec print_slot ppf slot =
else print_def ppf slot.def
and print_def ppf = function
| Link t -> print_slot ppf t
| Link t -> Format.fprintf ppf "Link(%a)" print_slot t
| Arrow (l, t, s) ->
Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
| Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
......@@ -110,9 +110,9 @@ let equal_type t1 t2 =
let visited = Hashtbl.create 17 in
let rec loop t1 t2 =
if t1 == t2 || t1.uid = t2.uid then true
else if Hashtbl.mem visited t1.uid then true
else if Hashtbl.mem visited (t1.uid, t2.uid) then true
else
let () = Hashtbl.add visited t1.uid () in
let () = Hashtbl.add visited (t1.uid, t2.uid) () in
loop_def t1 t2
and loop_def t1 t2 =
match (t1.def, t2.def) with
......@@ -157,7 +157,7 @@ module HashType = Hashtbl.Make (struct
| PVariant _ -> Hashtbl.hash "PVARIANT"
| Record _ -> Hashtbl.hash "RECORD"
| Builtin _ -> Hashtbl.hash "BUILTIN"
| Abstract s -> Hashtbl.hash "ABSTRACT"
| Abstract _ -> Hashtbl.hash "ABSTRACT"
| Var _ -> Hashtbl.hash "VAR"
let equal t1 t2 = equal_type t1 t2
......
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