Skip to content

GitLab

Commit 556fe80e authored by Kim Nguyễn's avatar Kim Nguyễn Committed by Pietro Abate
Browse files

Make it possible compile the ocaml/cduce interface against OCaml 3.1[12]/4.0[01]/4.02. 

Conflicts:
	Makefile.distrib
	depend

Change $$ in >> in types.ml for the substitution operator
parent 5abbc48d
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1429 additions and 46 deletions
Makefile.distrib
View file @ 556fe80e
......@@ -3,6 +3,7 @@ default: cduce
include Makefile.conf
include VERSION
OCAMLIFACE=ocamliface/$(ML_INTERFACE_VERSION)
ALL_TARGET=cduce cduce_lib.cma
INSTALL_BINARIES=cduce$(EXE)
......@@ -18,6 +19,7 @@ all: cduce_lib.cmxa
endif
PACKAGES = dynlink camlp4 ulex pcre num netstring
ALL_ML_IFACE = 3.x 4.01 4.02
# Call make with VERBOSE=true to get a trace of commands
......@@ -42,7 +44,7 @@ CAMLC_P = ocamlc -g
DEPEND_OCAMLDEP = misc/q_symbol.cmo
ifeq ($(PROFILE), true)
CAMLOPT_P = ocamlopt -p -inline 100
ifeq ($(NATIVE), false)
ifeq ($(NATIVE), false)
CAMLC_P = ocamlcp -p a
SYNTAX_PARSER =
DEPEND_OCAMLDEP =
......@@ -138,7 +140,8 @@ help:
# Source directories
DIRS = misc parser schema typing types compile runtime driver query ocamliface win32
DIRS_DEPEND = misc parser schema typing types compile runtime driver query win32
DIRS := $(DIRS_DEPEND) $(OCAMLIFACE)
CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
......@@ -182,14 +185,6 @@ schema/schema_types.ml: schema/schema_types.mli
compile/auto_pat.ml: compile/auto_pat.mli
cp $^ $@
ML_INTERFACE_OBJS = \
ocamliface/caml_cduce.cmo \
ocamliface/mltypes.cmo ocamliface/mlstub.cmo
ifneq ($(ML_INTERFACE), false)
OBJECTS += $(ML_INTERFACE_OBJS)
endif
ifneq ($(CURL), false)
OBJECTS += parser/cduce_curl.cmo
PACKAGES += curl
......@@ -229,22 +224,37 @@ endif
all: $(ALL_TARGET)
OBJECTS += driver/run.cmo
ML_INTERFACE_BASE_OBJS = caml_cduce.cmo mltypes.cmo mlstub.cmo
ML_INTERFACE_BASE_SRC = $(ML_INTERFACE_BASE_OBJS:.cmo=.ml) $(ML_INTERFACE_BASE_OBJS:.cmo=.mli)
ML_INTERFACE_OBJS = \
$(ML_INTERFACE_BASE_OBJS:%=$(OCAMLIFACE)/%)
OBJECTS_NO_MLIFACE := $(OBJECTS)
ifneq ($(ML_INTERFACE), false)
OBJECTS += $(ML_INTERFACE_OBJS)
endif
CDUCE = $(OBJECTS) driver/start.cmo
ALL_OBJECTS = $(OBJECTS) \
ALL_OBJECTS = $(OBJECTS_NO_MLIFACE) \
driver/start.cmo driver/examples.cmo \
driver/webiface.cmo driver/evaluator.cmo \
tools/validate.cmo \
$(ML_INTERFACE_OBJS) parser/cduce_curl.cmo \
parser/cduce_curl.cmo \
parser/cduce_netclient.cmo \
runtime/cduce_expat.cmo runtime/cduce_pxp.cmo
ALL_INTERFACES = schema/schema_types.mli
#types/var.mli types/boolVar.mli
DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
INCLUDES = $(DIRS:%=-I %)
INCLUDES_DEPEND = $(DIRS_DEPEND:%=-I %)
# -I +camlp4
cduce: $(CDUCE:.cmo=.$(EXTENSION))
......@@ -271,16 +281,22 @@ dtd2cduce: tools/dtd2cduce.ml
$(HIDE)$(OCAMLFIND) $(CAML) -o $@ -package "$(PXP_PACK) netcgi2" -linkpkg $^
.PHONY: compute_depend
compute_depend: $(DEPEND_OCAMLDEP)
@echo "Computing dependencies ..."
ocamlfind ocamldep -package "$(PACKAGES)" \
$(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
$(INCLUDES_DEPEND) $(SYNTAX_PARSER) -ppopt pa_extend.cmo -ppopt q_MLast.cmo $(DEPEND) > depend
for i in $(ALL_ML_IFACE); do \
ocamlfind ocamldep -package "$(PACKAGES)" \
$(INCLUDES_DEPEND) -I ocamliface/$$i $(SYNTAX_PARSER) -ppopt pa_extend.cmo -ppopt q_MLast.cmo \
$(ML_INTERFACE_BASE_SRC:%=ocamliface/$$i/%) >> depend;\
done
clean:
for i in $(CLEAN_DIRS); do \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \
done
rm -f misc/q_symbol.cmo.stamp
(cd ocamliface; $(MAKE) clean)
(cd $(OCAMLIFACE); $(MAKE) clean)
rm -f `find . -name "*~"`
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~ META
rm -f cduce$(EXE) ocamlprof.dump
......@@ -300,7 +316,7 @@ clean:
distclean: clean
rm -f Makefile.conf
ocamliface/mltypes.$(EXTENSION): ocamliface/caml_cduce.$(EXTENSION)
$(OCAMLIFACE)/mltypes.$(EXTENSION): $(OCAMLIFACE)/caml_cduce.$(EXTENSION)
$(ALL_INTERFACES): misc/q_symbol.cmo
$(ALL_OBJECTS:.cmo=.cmi): misc/q_symbol.cmo
......@@ -308,20 +324,19 @@ $(ALL_OBJECTS:.cmo=.cmx) caml_cduce.cmx: misc/q_symbol.cmo
$(ALL_OBJECTS) caml_cduce.cmo: misc/q_symbol.cmo
$(OCAMLIFACE)/mlstub.$(EXTENSION): SYNTAX += q_MLast.cmo
.SUFFIXES: .ml .mli .cmo .cmi .cmx
misc/q_symbol.cmo: misc/q_symbol.ml
@echo "Build $@"
$(HIDE) $(CAMLC) -c -pp camlp4orf $<
$(HIDE)$(CAMLC) -c -pp camlp4orf $<
.SUFFIXES: .ml .mli .cmo .cmi .cmx
parser/parser.cmo: PACKAGES += camlp4.extend
parser/parser.cmx: PACKAGES += camlp4.extend
types/boolVar.cmo: SYNTAX_PARSER=
types/boolVar.cmi: SYNTAX_PARSER=
types/boolVar.cmx: SYNTAX_PARSER=
parser/parser.cmo: PACKAGES += camlp4.extend
parser/parser.cmx: PACKAGES += camlp4.extend
.ml.cmo:
@echo "Build $@"
$(HIDE)$(CAMLC) -c $(INCLUDES) $(SYNTAX_PARSER) $<
......@@ -364,13 +379,13 @@ install_doc: doc
### Pack OCaml modules for the CDuce/OCaml interface
ocamliface/caml_cduce.cmo:
@cd ocamliface; \
$(OCAMLIFACE)/caml_cduce.cmo:
@cd $(OCAMLIFACE); \
$(MAKE) caml_cduce.cmo
ocamliface/caml_cduce.cmx:
@cd ocamliface; \
$(OCAMLIFACE)/caml_cduce.cmx:
@cd $(OCAMLIFACE); \
$(MAKE) caml_cduce.cmx
ocamliface/mlstub.cmo: SYNTAX += q_MLast.cmo
ocamliface/mlstub.cmx: SYNTAX += q_MLast.cmo
$(OCAMLIFACE)/mlstub.cmo: SYNTAX += q_MLast.cmo
$(OCAMLIFACE)/mlstub.cmx: SYNTAX += q_MLast.cmo
depend
View file @ 556fe80e
......@@ -336,20 +336,6 @@ tools/validate.cmo : schema/schema_types.cmi schema/schema_parser.cmi \
schema/schema_common.cmi
tools/validate.cmx : schema/schema_types.cmx schema/schema_parser.cmx \
schema/schema_common.cmx
ocamliface/mltypes.cmo : types/ident.cmo ocamliface/config.cmo \
parser/cduce_loc.cmi ocamliface/mltypes.cmi
ocamliface/mltypes.cmx : types/ident.cmx ocamliface/config.cmx \
parser/cduce_loc.cmx ocamliface/mltypes.cmi
ocamliface/mlstub.cmo : types/types.cmi typing/typer.cmi types/sequence.cmi \
misc/ns.cmi ocamliface/mltypes.cmi driver/librarian.cmi types/ident.cmo \
types/externals.cmi compile/compile.cmi parser/cduce_loc.cmi \
driver/cduce_config.cmi types/builtin_defs.cmi types/atoms.cmi \
parser/ast.cmo ocamliface/mlstub.cmi
ocamliface/mlstub.cmx : types/types.cmx typing/typer.cmx types/sequence.cmx \
misc/ns.cmx ocamliface/mltypes.cmx driver/librarian.cmx types/ident.cmx \
types/externals.cmx compile/compile.cmx parser/cduce_loc.cmx \
driver/cduce_config.cmx types/builtin_defs.cmx types/atoms.cmx \
parser/ast.cmx ocamliface/mlstub.cmi
parser/cduce_curl.cmo : runtime/value.cmi parser/url.cmi \
driver/cduce_config.cmi
parser/cduce_curl.cmx : runtime/value.cmx parser/url.cmx \
......@@ -445,9 +431,61 @@ driver/cduce.cmi : runtime/value.cmi types/atoms.cmi
runtime/cduce_pxp.cmi :
runtime/cduce_pxp.cmi :
runtime/cduce_expat.cmi :
ocamliface/mltypes.cmi : types/types.cmi types/ident.cmo
ocamliface/mlstub.cmi : parser/ast.cmo
runtime/cduce_expat.cmi :
runtime/cduce_pxp.cmi :
schema/schema_types.cmi : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
types/atoms.cmi
ocamliface/3.x/mltypes.cmo : types/ident.cmo ocamliface/3.x/config.cmo \
parser/cduce_loc.cmi ocamliface/3.x/mltypes.cmi
ocamliface/3.x/mltypes.cmx : types/ident.cmx ocamliface/3.x/config.cmx \
parser/cduce_loc.cmx ocamliface/3.x/mltypes.cmi
ocamliface/3.x/mlstub.cmo : types/types.cmi typing/typer.cmi \
types/sequence.cmi misc/ns.cmi ocamliface/3.x/mltypes.cmi \
driver/librarian.cmi types/ident.cmo types/externals.cmi \
compile/compile.cmi parser/cduce_loc.cmi driver/cduce_config.cmi \
types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
ocamliface/3.x/mlstub.cmi
ocamliface/3.x/mlstub.cmx : types/types.cmx typing/typer.cmx \
types/sequence.cmx misc/ns.cmx ocamliface/3.x/mltypes.cmx \
driver/librarian.cmx types/ident.cmx types/externals.cmx \
compile/compile.cmx parser/cduce_loc.cmx driver/cduce_config.cmx \
types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
ocamliface/3.x/mlstub.cmi
ocamliface/3.x/mltypes.cmi : types/types.cmi
ocamliface/3.x/mlstub.cmi : parser/ast.cmo
ocamliface/4.01/mltypes.cmo : types/ident.cmo ocamliface/4.01/config.cmo \
parser/cduce_loc.cmi ocamliface/4.01/mltypes.cmi
ocamliface/4.01/mltypes.cmx : types/ident.cmx ocamliface/4.01/config.cmx \
parser/cduce_loc.cmx ocamliface/4.01/mltypes.cmi
ocamliface/4.01/mlstub.cmo : types/types.cmi typing/typer.cmi \
types/sequence.cmi misc/ns.cmi ocamliface/4.01/mltypes.cmi \
driver/librarian.cmi types/ident.cmo types/externals.cmi \
compile/compile.cmi parser/cduce_loc.cmi driver/cduce_config.cmi \
types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
ocamliface/4.01/mlstub.cmi
ocamliface/4.01/mlstub.cmx : types/types.cmx typing/typer.cmx \
types/sequence.cmx misc/ns.cmx ocamliface/4.01/mltypes.cmx \
driver/librarian.cmx types/ident.cmx types/externals.cmx \
compile/compile.cmx parser/cduce_loc.cmx driver/cduce_config.cmx \
types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
ocamliface/4.01/mlstub.cmi
ocamliface/4.01/mltypes.cmi : types/types.cmi types/ident.cmo
ocamliface/4.01/mlstub.cmi : parser/ast.cmo
ocamliface/4.02/mltypes.cmo : types/ident.cmo ocamliface/4.02/config.cmo \
parser/cduce_loc.cmi ocamliface/4.02/mltypes.cmi
ocamliface/4.02/mltypes.cmx : types/ident.cmx ocamliface/4.02/config.cmx \
parser/cduce_loc.cmx ocamliface/4.02/mltypes.cmi
ocamliface/4.02/mlstub.cmo : types/types.cmi typing/typer.cmi \
types/sequence.cmi misc/ns.cmi ocamliface/4.02/mltypes.cmi \
driver/librarian.cmi types/ident.cmo types/externals.cmi \
compile/compile.cmi parser/cduce_loc.cmi driver/cduce_config.cmi \
types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
ocamliface/4.02/mlstub.cmi
ocamliface/4.02/mlstub.cmx : types/types.cmx typing/typer.cmx \
types/sequence.cmx misc/ns.cmx ocamliface/4.02/mltypes.cmx \
driver/librarian.cmx types/ident.cmx types/externals.cmx \
compile/compile.cmx parser/cduce_loc.cmx driver/cduce_config.cmx \
types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
ocamliface/4.02/mlstub.cmi
ocamliface/4.02/mltypes.cmi : types/types.cmi types/ident.cmo
ocamliface/4.02/mlstub.cmi : parser/ast.cmo
ocamliface/3.x/Makefile 0 → 100644
View file @ 556fe80e
# This Makefile generates caml_cduce.cmo/.cmx
# It must be called with an OCAML_SRC argument pointing to the root
# of an OCaml source tree.
include ../../Makefile.conf
all: caml_cduce.cmo caml_cduce.cmx
STDLIB=$(shell ocamlc -where)
ifeq ($(FORPACK),true)
FORPACKOPT1=-for-pack Cduce_lib.Caml_cduce
FORPACKOPT2=-for-pack Cduce_lib
else
FORPACKOPT1=
FORPACKOPT2=
endif
ocaml_files:
mkdir ocaml_files
$(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
cp location.ml ocaml_files/location.ml
cp ocaml_files/asttypes.mli ocaml_files/asttypes.ml
sed s=STDLIB=$(STDLIB)= config.ml > ocaml_files/config.ml
grep cmi_magic $(OCAML_SRC)/utils/config.mlp >> ocaml_files/config.ml
caml_cduce.cmo: ocaml_files
@echo "Build $@"
(cd ocaml_files; \
ocamlc $(FORPACKOPT1) -c $(COMPILE_FILES);\
ocamlc $(FORPACKOPT2) -pack -o $@ $(OBJECTS); \
cp caml_cduce.cmo caml_cduce.cmi ..)
caml_cduce.cmx: ocaml_files
@echo "Build $@"
(cd ocaml_files; ocamlopt $(FORPACKOPT1) -c $(COMPILE_FILES);\
ocamlopt $(FORPACKOPT2) -pack -o $@ $(XOBJECTS); \
cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
clean:
rm -Rf ocaml_files *~ *.cm*
COPY_FILES=\
typing/annot.mli \
utils/misc.ml utils/tbl.ml \
utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.ml \
parsing/asttypes.mli parsing/location.mli \
parsing/longident.ml \
typing/outcometree.mli \
typing/ident.ml typing/path.ml \
typing/primitive.ml typing/types.ml \
typing/btype.ml typing/oprint.ml \
typing/subst.ml typing/predef.ml \
typing/datarepr.ml typing/env.ml \
typing/ctype.ml typing/ctype.mli typing/printtyp.ml
COMPILE_FILES=\
asttypes.mli outcometree.mli asttypes.ml \
config.ml misc.ml tbl.ml \
clflags.ml consistbl.ml warnings.ml terminfo.ml \
location.mli location.ml annot.mli longident.ml \
ident.ml path.ml \
primitive.ml types.ml \
btype.ml oprint.ml \
subst.ml predef.ml \
datarepr.ml env.ml ctype.mli ctype.ml printtyp.ml
COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
ocamliface/3.x/location.ml 0 → 100644
View file @ 556fe80e
(* An implementation of the OCaml's Location signature (to cut dependencies
to other OCaml modules *)
open Lexing
type t = { loc_start: position; loc_end: position; loc_ghost: bool }
let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true }
let dummy x = assert false
let in_file = dummy
let init = dummy
let curr = dummy
let symbol_rloc = dummy
let symbol_gloc = dummy
let rhs_loc = dummy
let input_name = ref ""
let input_lexbuf = ref None
let get_pos_info = dummy
let print_error_cur_file = dummy
let print_error = dummy
let print = dummy
let print_warning = dummy
let prerr_warning = dummy
let echo_eof = dummy
let reset = dummy
let highlight_locations = dummy
ocamliface/3.x/mlstub.ml 0 → 100644
View file @ 556fe80e
This diff is collapsed.
ocamliface/3.x/mlstub.mli 0 → 100644
View file @ 556fe80e
(**************************************************************************)
(* The CDuce compiler *)
(* Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team *)
(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
(**************************************************************************)
open Camlp4.PreCast
val gen_wrapper: string list -> Ast.str_item
ocamliface/3.x/mltypes.ml 0 → 100644
View file @ 556fe80e
(**************************************************************************)
(* The CDuce compiler *)
(* Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team *)
(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
(**************************************************************************)
exception Error of string
module Loc = Cduce_loc
open Caml_cduce
open Caml_cduce.Types
(* Unfolding of OCaml types *)
exception PolyAbstract of string
let ocaml_env = ref Env.initial
type t = { uid : int; mutable recurs : int; mutable def : def }
and def =
| Link of t
| 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
| 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)
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)
let rec print_sep f sep ppf = function
| [] -> ()
| [x] -> f ppf x
| x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
let printed = ref IntMap.empty
let rec print_slot ppf slot =
if slot.recurs > 0 then
(
if IntMap.mem slot.uid !printed then
Format.fprintf ppf "X%i" slot.uid
else (
printed := IntMap.add slot.uid () !printed;
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
)
)
else
print_def ppf slot.def
and print_def ppf = function
| Link t -> print_slot ppf 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
| PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
| Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
| Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (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
| 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
and print_field ppf (lab,t) =
Format.fprintf ppf "%s:%a" lab print_slot t
let print = print_slot
let counter = ref 0
let new_slot () =
incr counter;
{ uid = !counter; recurs = 0; def = Abstract "DUMMY" }
let reg_uid t =
let saved = ref [] in
let rec aux t =
if t.recurs < 0 then () else begin
if t.uid > !counter then counter := t.uid;
saved := (t,t.recurs) :: !saved;
t.recurs <- (-1);
match t.def with
| Link t -> aux 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
| Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
| Builtin (_,tl) -> List.iter aux tl
| _ -> ()
end
in
aux t;
List.iter (fun (t,recurs) -> t.recurs <- recurs) !saved
let builtins =
List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
[
"list"; "Pervasives.ref";
"unit"; "array";
"Big_int.big_int";
"option";
"Cduce_lib.Value.t";
"Cduce_lib.Encodings.Utf8.t";
"Cduce_lib.Atoms.V.t";
]
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 constr_table = Hashtbl.create 1024
type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
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
then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
else
let args_id = List.map (fun t -> t.uid) args in
let k = (pn,args_id) in
try Hashtbl.find constr_table k
with Not_found ->
if StringSet.mem pn env.constrs then
failwith "Polymorphic recursion forbidden";
let slot = new_slot () in
slot.recurs <- 1;
Hashtbl.add constr_table k slot;
let decl =
try Env.find_type p !ocaml_env
with Not_found -> failwith ("Cannot resolve path " ^ pn) in
let env =
{ env with
constrs = StringSet.add pn env.constrs;
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
| Path.Pident _ -> ""
| Path.Pdot (p,_,_) -> Path.name p ^ "."
| _ -> assert false in
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)
| Type_record (f,_), _ ->
let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
Record (prefix, f, true)
| Type_abstract, Some t ->
Link (unfold env t)
| Type_abstract, None ->
(match args with
| [] -> 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 slot = new_slot () in
slot.def <-
(match ty.desc with
| Tarrow (l,t1,t2,_) ->
let t1 = unfold env t1 in
let t2 = unfold env t2 in
Arrow (l, t1,t2)
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
let fields =
List.fold_left
(fun accu (lab,f) ->
match f with
| Rpresent (Some t)
| Reither(true, [t], _, _) ->
(lab, Some (unfold env t)) :: accu
| 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 ->
(try Link (IntMap.find ty.id env.vars)
with Not_found -> Var (get_var ty.id))
| Tconstr (p,args,_) ->
Link (unfold_constr env p args)
| _ -> failwith "Unsupported feature"
);
slot
let unfold ty =
vars := [];
Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
vars = IntMap.empty } ty in
let n = List.length !vars in
vars := [];
(t,n)
(* Reading .cmi *)
let unsupported s =
raise (Error (Printf.sprintf "Unsupported feature (%s) found in .cmi" s))
let has_cmi name =
Config.load_path := Config.standard_library :: !Loc.obj_path;
try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
with Not_found -> false
let find_value v =
Config.load_path := Config.standard_library :: !Loc.obj_path;
let li = Longident.parse v in
ocaml_env := Env.initial;
let (_,vd) = Env.lookup_value li Env.initial in