Commit c3c01f2f authored by Julien Lopez's avatar Julien Lopez

Fix Variant and Record type for OCaml 4.

parent 7ad2e9eb
......@@ -16,15 +16,15 @@ and def =
| Arrow of string * t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of string * (string * t list) list * bool
| Record of string * (string * t) list * bool
| Variant of string * (Ident.t * t list * t option) list * bool
| Record of string * (Ident.t * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
module IntMap =
module IntMap =
Map.Make(struct type t = int let compare : t -> t -> int = compare end)
module IntSet =
module IntSet =
Set.Make(struct type t = int let compare : t -> t -> int = compare end)
module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
......@@ -46,7 +46,7 @@ let rec print_slot ppf slot =
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
)
)
else
else
print_def ppf slot.def
and print_def ppf = function
......@@ -64,15 +64,15 @@ and print_def ppf = function
and print_palt ppf = function
| lab, None -> Format.fprintf ppf "`%s" lab
| lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
and print_alt ppf = function
| (lab,[]) ->
Format.fprintf ppf "%s" lab
| (lab,l) ->
Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l
| (lab,[],_) ->
Format.fprintf ppf "%s" lab.Ident.name
| (lab,l,_) ->
Format.fprintf ppf "%s of [%a]" lab.Ident.name (print_sep print_slot ",") l
and print_field ppf (lab,t) =
Format.fprintf ppf "%s:%a" lab print_slot t
Format.fprintf ppf "%s:%a" lab.Ident.name print_slot t
let print = print_slot
......@@ -94,7 +94,9 @@ let reg_uid t =
| Arrow (_,t1,t2) -> aux t1; aux t2
| Tuple tl -> List.iter aux tl
| PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
| Variant (_,pl,_) -> List.iter (fun (_,tl) -> List.iter aux tl) pl
| Variant (_,pl,_) -> List.iter (function
(_,tl,Some o) -> List.iter aux (tl@[o])
| (_,tl,None) -> List.iter aux tl) pl
| Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
| Builtin (_,tl) -> List.iter aux tl
| _ -> ()
......@@ -106,32 +108,33 @@ let reg_uid t =
let builtins =
List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
[
"list"; "Pervasives.ref";
"list"; "Pervasives.ref";
"unit"; "array";
"Big_int.big_int";
"option";
"Cduce_lib.Value.t";
"Cduce_lib.Value.t";
"Cduce_lib.Encodings.Utf8.t";
"Cduce_lib.Atoms.V.t";
]
let vars = ref []
let get_var id =
let get_var id =
try List.assq id !vars
with Not_found ->
with Not_found ->
let i = List.length !vars in
vars := (id,i) :: !vars;
vars := (id,i) :: !vars;
i
let constr_table = Hashtbl.create 1024
type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
(* Take the file p, if it is from the builtins, open it; else *)
let rec unfold_constr env p args =
let args = List.map (unfold env) args in
let pn = Path.name p in
if StringSet.mem pn builtins
if StringSet.mem pn builtins
then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
else
let args_id = List.map (fun t -> t.uid) args in
......@@ -144,16 +147,16 @@ let rec unfold_constr env p args =
slot.recurs <- 1;
Hashtbl.add constr_table k slot;
let decl =
let decl =
try Env.find_type p !ocaml_env
with Not_found -> failwith ("Cannot resolve path " ^ pn) in
let env =
{ env with
let env =
{ env with
constrs = StringSet.add pn env.constrs;
vars =
List.fold_left2
(fun vars a t -> IntMap.add a.id t vars)
vars =
List.fold_left2
(fun vars a t -> IntMap.add a.id t vars)
env.vars decl.type_params args } in
let prefix = match p with
......@@ -161,13 +164,16 @@ let rec unfold_constr env p args =
| Path.Pdot (p,_,_) -> Path.name p ^ "."
| _ -> assert false in
slot.def <-
slot.def <-
(match decl.type_kind, decl.type_manifest with
| Type_variant (cstrs), _ ->
let cstrs =
List.map
(fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in
Variant (prefix, cstrs, true)
(* TODO: Check this solution *)
List.map (function (cst,f,Some o)
-> (cst,List.map (unfold env) f,Some (unfold env o))
| (cst,f,None) -> (cst,List.map (unfold env) f,None)) cstrs in
(*OLD: (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in *)
Variant (prefix, cstrs, true)
| Type_record (f,_), _ ->
let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
Record (prefix, f, true)
......@@ -178,34 +184,34 @@ let rec unfold_constr env p args =
| [] -> Abstract pn
| l ->raise (PolyAbstract pn)));
slot
and unfold env ty =
if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
let env = { env with seen = IntSet.add ty.id env.seen } in
let env = { env with seen = IntSet.add ty.id env.seen } in
let slot = new_slot () in
slot.def <-
(match ty.desc with
| Tarrow (l,t1,t2,_) ->
| Tarrow (l,t1,t2,_) ->
let t1 = unfold env t1 in
let t2 = unfold env t2 in
let t2 = unfold env t2 in
Arrow (l, t1,t2)
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
let fields =
let fields =
List.fold_left
(fun accu (lab,f) ->
(fun accu (lab,f) ->
match f with
| Rpresent (Some t)
| Reither(true, [t], _, _) ->
| Rpresent (Some t)
| Reither(true, [t], _, _) ->
(lab, Some (unfold env t)) :: accu
| Rpresent None
| Rpresent None
| Reither(true, [], _, _) -> (lab, None) :: accu
| Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
| Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
) []
rd.row_fields in
PVariant fields
| Tvar ->
| Tvar ->
(try Link (IntMap.find ty.id env.vars)
with Not_found -> Var (get_var ty.id))
| Tconstr (p,args,_) ->
......@@ -214,7 +220,7 @@ and unfold env ty =
);
slot
let unfold ty =
let unfold ty =
vars := [];
Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
......@@ -243,7 +249,7 @@ let find_value v =
let values_of_sig name sg =
List.fold_left
(fun accu v -> match v with
| Tsig_value (id,_) ->
| Tsig_value (id,_) ->
let id = Ident.name id in
(match id.[0] with
| 'a'..'z' | '_' ->
......@@ -255,14 +261,14 @@ let values_of_sig name sg =
) [] sg
let load_module name =
let load_module name =
Config.load_path := Config.standard_library :: !Loc.obj_path;
let li = Longident.parse name in
ocaml_env := Env.initial;
let (_,mty) = Env.lookup_module li Env.initial in
match mty with
| Tmty_signature sg -> values_of_sig name sg
| _ -> raise (Loc.Generic
| _ -> raise (Loc.Generic
(Printf.sprintf "Module %s is not a structure" name))
(*
......@@ -290,11 +296,11 @@ let read_cmi name =
let values = ref [] in
List.iter
(function
| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
let (unf,n) = unfold t in
if n !=0 then unsupported "polymorphic value";
values := (Ident.name id, t, unf) :: !values
| Tsig_type (id,t,rs) ->
| Tsig_type (id,t,rs) ->
Format.fprintf ppf "%a@."
!Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
| Tsig_value _ -> unsupported "external value"
......
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