Commit 07944a93 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-02-17 23:33:31 by jdemouth] Adds support for recursive types

Original author: jdemouth
Date: 2004-02-17 23:33:31+00:00
parent c6696087
......@@ -6,75 +6,126 @@ module CD = CDuce_all
(***********************************************************************************)
module Translations = struct
module StringHash = Hashtbl.Make(
struct
type t = string
let equal = (=)
let hash = Hashtbl.hash
end )
type t = cduce_t StringHash.t
(* Create an empty table. *)
let create = StringHash.create
(* Add a new translation in the table. *)
let add tbl id value = StringHash.add tbl id value
(* Get translation associated with [id]. *)
let find tbl id = StringHash.find tbl id
end
let translations = Translations.create 17
(***********************************************************************************)
let cd_type_nil =
let nil = CD.Atoms.atom ( CD.Atoms.V.mk_ascii "nil" ) in
CD.Types.atom nil
let rec from_desc_rec left = function
| ML_core ML_int ->
let lB = CD.Intervals.V.mk ( string_of_int min_int )
and uB = CD.Intervals.V.mk ( string_of_int max_int ) in
CD.Types.interval ( CD.Intervals.bounded lB uB )
| ML_core ML_bool ->
CD.Builtin_defs.bool
| ML_core ML_string ->
CD.Builtin_defs.string_latin1
| ML_core ML_unit ->
CD.Sequence.nil_type
| ML_extd ( ML_ident ( id, desc ) ) ->
from_desc_rec left desc
| ML_extd ( ML_option desc ) ->
let trans = from_desc_rec left desc in
CD.Types.cup trans cd_type_nil
| ML_extd ( ML_reference desc ) ->
let get = ML_extd ( ML_arrow ( None, ML_core ML_unit, desc ) )
and set = ML_extd ( ML_arrow ( None, desc, ML_core ML_unit ) ) in
let ref = ML_extd ( ML_record [ "get", get ; "set", set ] ) in
from_desc_rec left ref
| ML_extd ( ML_list d ) ->
CD.Sequence.star ( from_desc_rec left d )
| ML_extd ( ML_arrow ( lbl, d1, d2 ) ) ->
let l = from_desc_rec true d1
and r = from_desc_rec false d2 in
CD.Types.arrow ( CD.Types.cons l ) ( CD.Types.cons r )
| ML_extd ( ML_tuple list ) ->
let rec times_tail_rec prev = function
| [] -> assert false
| d::[] ->
let cons = CD.Types.cons ( from_desc_rec left d ) in
CD.Types.times cons prev
| d::tl ->
let cons = CD.Types.cons ( from_desc_rec left d ) in
let cons = CD.Types.cons ( CD.Types.times cons prev ) in
times_tail_rec cons tl in
let ( hd,tl ) = match ( List.rev list ) with
| hd::tl -> ( hd, tl ) | _ -> assert false in
times_tail_rec ( CD.Types.cons ( from_desc_rec left hd ) ) tl
| ML_extd ( ML_variant list ) ->
List.fold_left (
fun t ( name, desc ) ->
let desc = match desc with
| None -> cd_type_nil
| Some desc -> from_desc_rec left desc in
let atom = CD.Atoms.atom ( CD.Atoms.V.mk_ascii name ) in
let atom = CD.Types.cons ( CD.Types.atom atom ) in
let pair = CD.Types.times atom ( CD.Types.cons desc ) in
CD.Types.cup t pair
) CD.Types.empty list
| ML_extd ( ML_record list ) ->
let rec from_ocaml_rec left array = function
| { ml_id = id; ml_kind = ML_type; ml_decl = decl } ->
CD.Types.descr ( from_ocaml_type left array id decl )
| { ml_kind = ML_value; ml_decl = decl } ->
from_decl left array decl
| { ml_kind = ML_module _ } -> assert false
and from_ocaml_type left array id decl =
try
Translations.find translations id
with Not_found ->
let node = CD.Types.make () in
Translations.add translations id node;
let desc = from_decl left array decl in
CD.Types.define node desc;
node
and from_decl left array = function
| ML_abstract desc ->
CD.Types.descr ( from_desc left array desc )
| ML_record list ->
let list = List.map (
fun ( name, desc ) ->
let name_ns = CD.Ns.mk_ascii "" in
let name_val = CD.Encodings.Utf8.mk name in
let desc = from_desc_rec left desc in
( name_ns, name_val ), desc
let desc = from_desc left array desc in
( name_ns, name_val ), CD.Types.descr desc
) list in
if left then Format.eprintf "Record opened@.";
CD.Types.rec_of_list ~opened:left list
| ML_extd ( ML_external ( list, name, desc ) ) ->
from_desc_rec left desc
| ML_extd ( ML_module _ ) ->
failwith "from_ocaml : cannot be used on module"
| ML_variant list ->
List.fold_left (
fun t ( name, list ) ->
let atom = CD.Atoms.atom ( CD.Atoms.V.mk_ascii name ) in
let atom = CD.Types.cons ( CD.Types.atom atom ) in
let desc = match list with
| [] ->
CD.Types.descr atom
| hd :: [] ->
let desc = from_desc left array hd in
CD.Types.times atom desc
| _ ->
let tuple = tuple_of_list left array list in
CD.Types.times atom tuple
in
CD.Types.cup t desc
) CD.Types.empty list
| ML_nil -> assert false
and from_desc left array = function
| ML_arrow ( lbl, d1, d2 ) ->
let l = from_desc true array d1
and r = from_desc false array d2 in
CD.Types.cons ( CD.Types.arrow l r )
| ML_bool ->
CD.Types.cons ( CD.Builtin_defs.bool )
| ML_ident ( id, params, ocaml ) ->
let node = from_ocaml_type left params ocaml.ml_id ocaml.ml_decl in
node
| ML_int ->
let lB = CD.Intervals.V.mk ( string_of_int min_int )
and uB = CD.Intervals.V.mk ( string_of_int max_int ) in
CD.Types.cons ( CD.Types.interval ( CD.Intervals.bounded lB uB ) )
| ML_list d ->
let desc = CD.Types.descr ( from_desc left array d ) in
CD.Types.cons ( CD.Sequence.star desc )
| ML_option desc ->
let trans = CD.Types.descr ( from_desc left array desc ) in
CD.Types.cons ( CD.Types.cup trans cd_type_nil )
| ML_reference desc ->
let get = ML_arrow ( None, ML_unit, desc )
and set = ML_arrow ( None, desc, ML_unit ) in
let ref = ML_record [ "get", get ; "set", set ] in
CD.Types.cons ( from_decl left array ref )
| ML_string ->
CD.Types.cons ( CD.Builtin_defs.string_latin1 )
| ML_tuple list ->
assert ( List.length list >= 2 );
tuple_of_list left array list
| ML_unit ->
CD.Types.cons ( CD.Sequence.nil_type )
| ML_var id ->
from_desc left array array.( id )
and tuple_of_list left array list =
let rec internal tail = function
| hd :: [] ->
let desc = from_desc left array hd in
CD.Types.times desc ( CD.Types.cons tail )
| hd :: tl ->
let desc = from_desc left array hd in
let tail = CD.Types.times desc ( CD.Types.cons tail ) in
internal tail tl
| [] -> assert false in
let tail = CD.Types.descr ( from_desc left array ( List.hd list ) ) in
CD.Types.cons ( internal tail ( List.tl list ) )
(***********************************************************************************)
......@@ -85,11 +136,8 @@ module Type : sig
val is_subtype : t -> t -> bool
end = struct
type t = cduce_t
let from_ocaml ml_typ = from_desc_rec true ml_typ.ml_desc
let from_ocaml ocaml = from_ocaml_rec true [||] ocaml
let print = CD.Types.Print.print
let is_subtype t1 t2 = CD.Types.subtype t1 t2
end
......
......@@ -16,15 +16,15 @@ let report_error = function
Format.eprintf "Error in file %s.cmi:@." file;
Cduce.Type.print Format.err_formatter cd_t;
Format.eprintf "\nis not a subtype of@.";
Ocaml.Type.print Format.err_formatter ml_t
Ocaml.Type.print Format.err_formatter ( true, [ ml_t ] )
(***********************************************************************************)
let run ml_cu cd_cu =
let file = Cduce.CompUnit.module_name cd_cu in
try Ocaml.CompUnit.iter (
fun ml_t -> match ml_t.Types.ml_kind with
| Types.ML_value -> (
fun ( _, list ) -> match list with
| [ { Types.ml_kind = Types.ML_value } as ml_t ] -> (
try
let cd_type = Cduce.Type.from_ocaml ml_t
and cd_base = Cduce.CompUnit.find_value cd_cu ml_t.Types.ml_name in
......
......@@ -44,21 +44,45 @@ type code_t =
| To_CDuce_record of ( string * code_t ) list
| To_CDuce_string
| To_CDuce_tuple of code_t list
| To_CDuce_type of string
| To_CDuce_unit
| To_CDuce_variant of ( string * code_t option ) list
| To_OCaml_bool
| To_OCaml_fun of string * code_t * code_t
| To_OCaml_int
| To_OCaml_list of code_t
| To_OCaml_option of code_t
| To_OCaml_record of ( string * code_t ) list
| To_OCaml_string
| To_OCaml_tuple of code_t list
| To_OCaml_type of string
| To_OCaml_unit
| To_OCaml_variant of ( string * code_t option ) list
type value_t =
| Type_to_cd of string * bool * bool * code_t
| Type_to_ml of string * bool * bool * code_t
| Value of string * int * code_t
(***********************************************************************************)
let rec dump fmt = function
| Type_to_cd ( name, first, is_rec, code ) ->
let () = match first, is_rec with
| true, true -> Format.fprintf fmt "let rec "
| true, false -> Format.fprintf fmt "let "
| false, _ -> Format.fprintf fmt "and "
in
Format.fprintf fmt "ocaml2cduce__%s cdo2cmo__val = @." name;
dump_code fmt "cdo2cmo__val" code
| Type_to_ml ( name, first, is_rec, code ) ->
let () = match first, is_rec with
| true, true -> Format.fprintf fmt "let rec "
| true, false -> Format.fprintf fmt "let "
| false, _ -> Format.fprintf fmt "and "
in
Format.fprintf fmt "cduce2ocaml__%s cdo2cmo__val = @." name;
dump_code fmt "cdo2cmo__val" code
| Value ( name, slot, code ) ->
Format.fprintf fmt "let %s =" name;
Format.fprintf fmt " let cdo2cmo__val = @.";
......@@ -118,7 +142,7 @@ and dump_code fmt name = function
| [ x ] -> Format.fprintf fmt "%s__%d " name n
| hd :: tl ->
Format.fprintf fmt "%s__%d, " name n;
print_proj ( n + 1) tl in
print_proj ( n + 1 ) tl in
let rec print_list n = function
| d1 :: [ d2 ] ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
......@@ -137,6 +161,8 @@ and dump_code fmt name = function
print_proj 0 list;
Format.fprintf fmt ") = %s in@." name;
print_list 0 list
| To_CDuce_type id ->
Format.fprintf fmt "ocaml2cduce__%s %s" id name
| To_CDuce_variant list ->
let print ( label, desc ) = match desc with
| None ->
......@@ -191,78 +217,171 @@ and dump_code fmt name = function
Format.fprintf fmt " ( cdo2cmo__seq [] cdo2cmo__l2 )@.";
Format.fprintf fmt " | _ -> assert false in@.";
Format.fprintf fmt " cdo2cmo__seq [] %s@." name
| To_OCaml_option code ->
Format.fprintf fmt " match %s with@." name;
Format.fprintf fmt " | CDuce_all.Value.nil -> None@.";
Format.fprintf fmt " | %s -> Some (@." name;
dump_code fmt name code;
Format.fprintf fmt " )@."
| To_OCaml_record list -> assert false
| To_OCaml_string ->
Format.fprintf fmt " CDuce_all.Value.get_string_latin1 %s@." name
| To_OCaml_tuple list ->
let rec proj n = function
| [ _ ; _ ] ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt "cdo2cmo__%d, cdo2cmo__%d )@." n ( n + 1 )
| _ :: tl ->
Format.fprintf fmt "CDuce_all.Value.Pair ( cdo2cmo__%d,@." n;
proj ( n + 1 ) tl;
Format.fprintf fmt ")@."
| _ -> assert false in
let rec print_list n = function
| [ d1 ; d2 ] ->
dump_code fmt ( Format.sprintf "cdo2cmo__%d" n ) d1;
Format.fprintf fmt ",@.";
dump_code fmt ( Format.sprintf "cdo2cmo__%d" ( n + 1 ) ) d2
| hd :: tl ->
dump_code fmt ( Format.sprintf "cdo2cmo__%d" n ) hd;
Format.fprintf fmt ",@.";
print_list ( n + 1 ) tl
| _ -> assert false in
Format.fprintf fmt "let ";
proj 0 list;
Format.fprintf fmt "= %s in (@." name;
print_list 0 list;
Format.fprintf fmt ")@."
| To_OCaml_type id ->
Format.fprintf fmt "cduce2ocaml__%s %s@." id name
| To_OCaml_unit ->
Format.fprintf fmt " ()@."
| To_OCaml_variant list ->
let rec print_list = function
| [] ->
Format.fprintf fmt " | _ -> assert false @."
| ( field, None ) :: tl ->
Format.fprintf fmt " | \"%s\" -> %s@." field field;
print_list tl
| ( field, Some desc ) :: tl ->
Format.fprintf fmt " | \"%s\" -> %s ( @." field field;
dump_code fmt "cdo2cmo__desc" desc;
Format.fprintf fmt " ) @.";
print_list tl in
Format.fprintf fmt " let cdo2cmo__atom, cdo2cmo__desc = match %s with @." name;
Format.fprintf fmt " | CDuce_all.Value.Pair ( @.";
Format.fprintf fmt " CDuce_all.Value.Atom cdo2cmo__atom, @.";
Format.fprintf fmt " cdo2cmo__desc ) -> @.";
Format.fprintf fmt " cdo2cmo__atom, cdo2cmo__desc @.";
Format.fprintf fmt " | _ -> assert false in@.";
Format.fprintf fmt " match CDuce_all.Ns.QName.to_string ( @.";
Format.fprintf fmt " CDuce_all.Atoms.V.value cdo2cmo__atom )@.";
Format.fprintf fmt " with @.";
print_list list
let dump_list fmt list =
List.iter ( fun value -> dump fmt value ) list
let rec generate_ml ctx name desc =
let slot = ml_value_slot ctx name in
let code = generate_to_ml ctx "cdo2cmo__val" desc in
Value ( name, slot, code )
and generate_to_ml ctx name desc =
generate_to_ml_rec ctx (*name*) desc
and generate_to_ml ctx name = function
| ML_abstract desc ->
generate_desc_to_ml ctx name desc
| ML_record list ->
let list = List.map (
fun ( field, desc ) ->
let d = generate_desc_to_ml_rec ctx desc
in field, d
) list in To_OCaml_record list
| ML_variant list ->
let list = List.map (
fun ( field, desc ) -> match desc with
| [] -> field, None
| [ x ] ->
let d = generate_desc_to_ml_rec ctx x in
field, Some d
| _ ->
let d = generate_desc_to_ml_rec ctx ( ML_tuple desc ) in
field, Some d
) list in
To_OCaml_variant list
| ML_nil -> assert false
and generate_desc_to_ml ctx name desc =
generate_desc_to_ml_rec ctx (*name*) desc
and generate_to_ml_rec ctx (* name *) = function
| ML_core ML_bool -> To_OCaml_bool
| ML_core ML_int -> To_OCaml_int
| ML_core ML_string -> To_OCaml_string
| ML_core ML_unit -> To_OCaml_unit
| ML_extd ML_arrow ( lbl, d1, d2 ) ->
and generate_desc_to_ml_rec ctx (* name *) = function
| ML_bool -> To_OCaml_bool
| ML_int -> To_OCaml_int
| ML_string -> To_OCaml_string
| ML_unit -> To_OCaml_unit
| ML_arrow ( lbl, d1, d2 ) ->
let ctx, lbl = generate_ml_arg ctx lbl in
let code1 = generate_to_cd ctx lbl d1 in
let code2 = generate_to_ml ctx lbl d2 in
let code1 = generate_desc_to_cd ctx lbl d1 in
let code2 = generate_desc_to_ml ctx lbl d2 in
To_OCaml_fun ( lbl, code1, code2 )
| ML_extd ML_external ( _, _, desc ) ->
generate_to_ml_rec ctx desc
| ML_extd ML_ident ( _, desc ) ->
generate_to_ml_rec ctx desc
| ML_extd ML_list d ->
To_OCaml_list ( generate_to_ml_rec ctx d )
| _ -> assert false
| ML_ident ( _, _, { Types.ml_id = id } ) ->
To_OCaml_type id
| ML_list d ->
To_OCaml_list ( generate_desc_to_ml_rec ctx d )
| ML_option d ->
To_OCaml_option ( generate_desc_to_ml_rec ctx d )
| ML_reference _ -> assert false
| ML_tuple list ->
let list = List.map ( generate_desc_to_ml_rec ctx ) list in
To_OCaml_tuple list
| ML_var _ -> assert false
and generate_to_cd ctx name desc =
generate_to_cd_rec ctx name desc
and generate_to_cd_rec ctx name = function
| ML_core ML_bool -> To_CDuce_bool
| ML_core ML_int -> To_CDuce_int
| ML_core ML_string -> To_CDuce_string
| ML_core ML_unit -> To_CDuce_unit
| ML_extd ML_arrow ( lbl, d1, d2 ) ->
let ctx, lbl = Ctx.generate_name ctx in
let code1 = generate_to_ml ctx lbl d1 in
let code2 = generate_to_cd ctx name d2 in
To_CDuce_fun ( name, lbl, code1, code2 )
| ML_extd ML_external ( _, _, desc ) ->
generate_to_cd_rec ctx name desc
| ML_extd ML_ident ( _, desc ) ->
generate_to_cd_rec ctx name desc
| ML_extd ML_list d ->
To_CDuce_list ( generate_to_cd_rec ctx name d )
| ML_extd ML_option d ->
To_CDuce_option ( generate_to_cd_rec ctx name d )
| ML_extd ML_record list ->
and generate_to_cd ctx name = function
| ML_abstract desc ->
generate_desc_to_cd ctx name desc
| ML_record list ->
let list = List.map (
fun ( field, desc ) ->
let d = generate_to_cd_rec ctx name desc in
let d = generate_desc_to_cd_rec ctx name desc in
field, d
) list in To_CDuce_record list
| ML_extd ML_reference d -> assert false
(* To_CDuce_reference ( generate_to_cd_rec ctx name d ) *)
| ML_extd ML_tuple list ->
let list = List.map ( generate_to_cd_rec ctx name ) list in
To_CDuce_tuple list
| ML_extd ML_variant list ->
| ML_variant list ->
let list = List.map (
fun ( field, desc ) -> match desc with
| None -> field, None
| Some desc ->
let d = generate_to_cd_rec ctx name desc in
| [] -> field, None
| [ x ] ->
let d = generate_desc_to_cd_rec ctx name x in
field, Some d
) list in To_CDuce_variant list
| _ -> assert false
| _ ->
let d = generate_desc_to_cd_rec ctx name ( ML_tuple desc ) in
field, Some d
) list in
To_CDuce_variant list
| ML_nil -> assert false
and generate_desc_to_cd ctx name desc =
generate_desc_to_cd_rec ctx name desc
and generate_desc_to_cd_rec ctx name = function
| ML_bool -> To_CDuce_bool
| ML_int -> To_CDuce_int
| ML_string -> To_CDuce_string
| ML_unit -> To_CDuce_unit
| ML_arrow ( lbl, d1, d2 ) ->
let ctx, lbl = Ctx.generate_name ctx in
let code1 = generate_desc_to_ml ctx lbl d1 in
let code2 = generate_desc_to_cd ctx name d2 in
To_CDuce_fun ( name, lbl, code1, code2 )
| ML_ident ( _, _, { Types.ml_id = id } ) ->
To_CDuce_type id
| ML_list d ->
To_CDuce_list ( generate_desc_to_cd_rec ctx name d )
| ML_option d ->
To_CDuce_option ( generate_desc_to_cd_rec ctx name d )
| ML_reference d -> assert false
(* To_CDuce_reference ( generate_desc_to_cd_rec ctx name d ) *)
| ML_tuple list ->
let list = List.map ( generate_desc_to_cd_rec ctx name ) list in
To_CDuce_tuple list
| ML_var _ -> assert false
and generate_ml_arg ctx = function
| Some lbl -> ctx, lbl
......@@ -270,13 +389,31 @@ and generate_ml_arg ctx = function
and ml_value_slot ctx = Cduce.CompUnit.find_value_slot ( Ctx.comp_unit ctx )
let generate_type_to_ml ctx is_rec list =
let rec internal first tail = function
| [] -> tail
| { Types.ml_id = id; Types.ml_decl = decl } :: tl ->
let code = generate_to_ml ctx "cdo2cmo__val" decl in
internal false ( tail @ [ Type_to_ml ( id, first, is_rec, code ) ] ) tl
in
internal true [] list
let generate_type_to_cd ctx is_rec list =
let rec internal first tail = function
| [] -> tail
| { Types.ml_id = id; Types.ml_decl = decl } :: tl ->
let code = generate_to_cd ctx "cdo2cmo__val" decl in
internal false ( tail @ [ Type_to_cd ( id, first, is_rec, code ) ] ) tl
in
internal true [] list
(***********************************************************************************)
let ml_print fmt cu t =
let name = t.ml_name
and desc = t.ml_desc
and decl = t.ml_decl
and kind = t.ml_kind in
let code = generate_ml ( Ctx.create cu ) name desc in dump fmt code
let code = generate_ml ( Ctx.create cu ) name decl in dump fmt code
(***********************************************************************************)
......@@ -295,10 +432,20 @@ end = struct
Format.fprintf fmt "cdo2cmo__cu;@.";
Format.fprintf fmt "cdo2cmo__cu@.";
Ocaml.CompUnit.iter (
fun ml_type -> match ml_type.Types.ml_kind with
| Types.ML_type ->
Ocaml.Type.print fmt ml_type
| Types.ML_value ->
fun ( need, list ) -> match list with
| [ { Types.ml_kind = Types.ML_type } as ml_type ] ->
Ocaml.Type.print fmt ( need, [ ml_type ] );
let code = generate_type_to_ml ( Ctx.create cd_cu ) false [ ml_type ] in
dump_list fmt code;
let code = generate_type_to_cd ( Ctx.create cd_cu ) false [ ml_type ] in
dump_list fmt code
| ( { Types.ml_kind = Types.ML_type } :: tl ) ->
Ocaml.Type.print fmt ( need, list );
let code = generate_type_to_ml ( Ctx.create cd_cu ) true list in
dump_list fmt code;
let code = generate_type_to_cd ( Ctx.create cd_cu ) true list in
dump_list fmt code
| [ { Types.ml_kind = Types.ML_value } as ml_type ] ->
ml_print fmt cd_cu ml_type
| _ -> ()
) ml_cu
......
......@@ -32,7 +32,6 @@ let () =
try
let ml_cu = ML.CompUnit.from_bytecode ml_file
and cd_cu = CD.CompUnit.from_bytecode cd_file in
ML.CompUnit.iter (ML.Type.print Format.err_formatter) ml_cu;
Checker.run ml_cu cd_cu;
let out_chan = open_out out_file in
let out_fmt = Format.formatter_of_out_channel out_chan in
......
This diff is collapsed.
type ocaml_t =
{ ml_name : string;
ml_kind : ocaml_kind;
ml_desc : ocaml_desc; }
{ ml_id: string;
ml_name: string;
ml_kind: ocaml_kind;
mutable ml_rec: bool;
mutable ml_decl: ocaml_decl }
and ocaml_kind =
| ML_type
| ML_value
| ML_modtype
and ocaml_desc =
| ML_core of ocaml_core_desc
| ML_extd of ocaml_extd_desc
and ocaml_extd_desc =
| ML_ident of string