Commit 36ba17f2 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-01-23 17:33:10 by jdemouth] Empty log message

Original author: jdemouth
Date: 2004-01-23 17:34:00+00:00
parent 1ee065bb
OBJECTS=src/types.cmo src/ocaml.cmo src/cduce.cmo src/checker.cmo \
src/generator.cmo src/main.cmo
INTERFACES=$(shell for o in $(OBJECTS); do echo $${o%cmo}cmi; done )
BIN=bin/cdo2cmo
INCLUDES=-I src -I lib
LIBS=lib/oCaml_all.cma lib/cDuce_all.cma
all: $(BIN)
$(BIN):$(OBJECTS)
ocamlc -g -o $(BIN) $(LIBS) $(OBJECTS)
.SUFFIXES: .mli .ml .cmi .cmo
.mli.cmi:
ocamlc -g $(INCLUDES) $(LIBS) -c $<
.ml.cmo:
ocamlc -g $(INCLUDES) $(LIBS) -c $<
clean:
rm -f $(OBJECTS) $(INTERFACES) $(BIN) src/*~
.depend depend:
rm -f .depend
ocamldep src/*.ml src/*.mli > .depend
include .depend
open Types
(***********************************************************************************)
module CD = CDuce_all
(***********************************************************************************)
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 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
) 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"
(***********************************************************************************)
module Type : sig
type t = cduce_t
val from_ocaml : ocaml_t -> t
val print : Format.formatter -> t -> unit
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 print = CD.Types.Print.print
let is_subtype t1 t2 = CD.Types.subtype t1 t2
end
(***********************************************************************************)
module CompUnit : sig
type t
val from_bytecode : string -> t
val find_type : t -> string -> cduce_t
val find_value : t -> string -> cduce_t
val find_value_slot : t -> string -> int
val module_name : t -> string
end = struct
type t =
{ cu_mod: string;
cu_unit: CD.Types.CompUnit.t;
cu_typer: CD.Typer.t; }
let from_bytecode file_name =
let mod_name = Filename.chop_suffix file_name ".cdo" in
let cu = CD.Types.CompUnit.mk ( CD.Ident.U.mk_latin1 mod_name ) in
CD.Librarian.import cu;
let ty = !( CD.Typer.from_comp_unit ) cu in
{ cu_mod = mod_name; cu_unit = cu; cu_typer = ty }
let find_type cu name =
let id = CD.Ident.ident ( CD.Ident.U.mk_latin1 name ) in
CD.Typer.find_type id cu.cu_typer
let find_value cu name =
let id = CD.Ident.ident ( CD.Ident.U.mk_latin1 name ) in
CD.Typer.find_value id cu.cu_typer
let find_value_slot cu ( name : string ) =
let cu = cu.cu_unit in
let env = !CD.Compile.from_comp_unit cu in
let id = CD.Ident.ident ( CD.Ident.U.mk_latin1 name ) in
let f_slot = CD.Compile.find id env in
match f_slot with CD.Lambda.Global i -> i
| _ -> assert false
let module_name cu = cu.cu_mod
end
(***********************************************************************************)
type error =
| Undefined_value of string * string
| Type_mismatch of string * Ocaml.Type.t * Cduce.Type.t
exception Error of error
let error e = raise ( Error e )
let report_error = function
| Undefined_value ( file, func ) ->
Format.eprintf "Error in file %s.cmi:@." file;
Format.eprintf "Value %s has no counterpart in file %s.cdo@." func file
| Type_mismatch ( file, ml_t, cd_t ) ->
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
(***********************************************************************************)
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 -> (
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
if not ( Cduce.Type.is_subtype cd_base cd_type )
then error ( Type_mismatch ( file, ml_t, cd_base ) );
with Not_found ->
error ( Undefined_value ( file, ml_t.Types.ml_name ) ) )
| _ -> ()
) ml_cu
with Error e -> report_error e; exit 1
open Types
(***********************************************************************************)
(* Context used to decide how to print a type. *)
module Ctx = struct
type t = {
ctx_cu: Cduce.CompUnit.t;
(* Parameter counter. *)
ctx_counter: int }
(* Create top position. *)
let create cu =
{ ctx_cu = cu;
ctx_counter = 0 }
(* Get CDuce compilation unit. *)
let comp_unit ctx = ctx.ctx_cu
(* Generate a parameter name. *)
let generate_name ctx =
{ ctx with ctx_counter = (ctx.ctx_counter + 1) },
Format.sprintf "cdo2cmo__p__%d" ctx.ctx_counter
end
(***********************************************************************************)
(* ******************************************************************************* *
* Our translation scheme is the following: *
* Consider the following value : val f : int -> int, we have to translate left *
* most [ int ] as an argument from ocaml value to cduce one. The right one has *
* to be translated as a return value from cduce to ocaml. *
* In fact we'll translate this declaration by something like: *
* let f cdo2cmo_0 = *
* let cdo2cmo_0 = (* its translation to CDuce, see CD_of_int *) in *
* let cdo2cmo_r = (* load f according to its slot in CDuce comp. env. *) in *
* let cdo2cmo_r = (* apply cdo2cmo_r to cdo2cmo_0, see CD_apply *) in *
* match cdo2cmo_r with (* translate to int, see CD_to_int *) *
* ******************************************************************************* *)
type code_t =
| To_CDuce_bool
| To_CDuce_fun of string * string * code_t * code_t
| To_CDuce_int
| To_CDuce_list of code_t
| To_CDuce_option of code_t
| To_CDuce_record of ( string * code_t ) list
| To_CDuce_string
| To_CDuce_tuple of code_t list
| 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_string
| To_OCaml_unit
type value_t =
| Value of string * int * code_t
(***********************************************************************************)
let rec dump fmt = function
| Value ( name, slot, code ) ->
Format.fprintf fmt "let %s =" name;
Format.fprintf fmt " let cdo2cmo__val = @.";
Format.fprintf fmt " !CDuce_all.Eval.from_comp_unit cdo2cmo__cu %d in@." slot;
dump_code fmt "cdo2cmo__val" code
and dump_code fmt name = function
| To_CDuce_bool ->
Format.fprintf fmt " CDuce_all.Value.vbool %s@." name
| To_CDuce_fun ( func, arg, code1, code2 ) ->
Format.fprintf fmt "let %s = fun %s -> @." func arg;
Format.fprintf fmt " let cdo2cmo__p = @.";
dump_code fmt arg code1;
Format.fprintf fmt " in @.";
Format.fprintf fmt " let cdo2cmo__val = %s cdo2cmo__p in@." func;
dump_code fmt "cdo2cmo__val" code2;
Format.fprintf fmt " in@.";
Format.fprintf fmt " CDuce_all.Value.Abstraction( [], %s )@." func
| To_CDuce_int ->
Format.fprintf fmt " CDuce_all.Value.const (@.";
Format.fprintf fmt " CDuce_all.Types.Integer (@.";
Format.fprintf fmt " CDuce_all.Intervals.V.mk (@.";
Format.fprintf fmt " string_of_int %s ))) @." name
| To_CDuce_list code ->
Format.fprintf fmt " CDuce_all.Value.sequence (@.";
Format.fprintf fmt " List.map (fun cdo2cmo__e -> @.";
dump_code fmt "cdo2cmo__e" code;
Format.fprintf fmt " ) %s )@." name
| To_CDuce_option code ->
Format.fprintf fmt " match %s with @." name;
Format.fprintf fmt " | None -> CDuce_all.Value.nil@.";
Format.fprintf fmt " | Some %s -> (@." name;
dump_code fmt name code;
Format.fprintf fmt " )@."
| To_CDuce_record list ->
Format.fprintf fmt " CDuce_all.Value.vrecord [@.";
let rec print_list = function
| [] -> ()
| [ ( field, desc ) ] ->
Format.fprintf fmt "( CDuce_all.Ns.mk_ascii \"\", @.";
Format.fprintf fmt " CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
dump_code fmt ( Format.sprintf "%s.%s" name field ) desc
| ( field, desc ) :: tl ->
Format.fprintf fmt "( CDuce_all.Ns.mk_ascii \"\", @.";
Format.fprintf fmt " CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
dump_code fmt ( Format.sprintf "%s.%s" name field ) desc;
print_list tl in
print_list list;
Format.fprintf fmt " ]@."
| To_CDuce_string ->
Format.fprintf fmt " CDuce_all.Value.string_latin1 %s@." name
| To_CDuce_unit ->
Format.fprintf fmt " CDuce_all.Value.sequence [] @."
| To_CDuce_tuple list ->
let rec print_proj n = function
| [] -> assert false
| [ x ] -> Format.fprintf fmt "%s__%d " name n
| hd :: tl ->
Format.fprintf fmt "%s__%d, " name n;
print_proj ( n + 1) tl in
let rec print_list n = function
| d1 :: [ d2 ] ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
dump_code fmt ( Format.sprintf "%s__%d" name n ) d1;
Format.fprintf fmt ", ";
dump_code fmt ( Format.sprintf "%s__%d" name ( n + 1 ) ) d2;
Format.fprintf fmt ")"
| hd :: tl ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
dump_code fmt ( Format.sprintf "%s__%d" name n ) hd;
Format.fprintf fmt ", ";
print_list ( n + 1 ) tl;
Format.fprintf fmt ")"
| _ -> assert false in
Format.fprintf fmt "let ( ";
print_proj 0 list;
Format.fprintf fmt ") = %s in@." name;
print_list 0 list
| To_CDuce_variant list ->
let print ( label, desc ) = match desc with
| None ->
Format.fprintf fmt " | %s -> @." label;
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt " CDuce_all.Value.Atom ( @.";
Format.fprintf fmt " CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
Format.fprintf fmt " CDuce_all.Value.nil )@."
| Some desc ->
Format.fprintf fmt " | %s cdo2cmo__x -> @." label;
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt " CDuce_all.Value.Atom ( @.";
Format.fprintf fmt " CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
dump_code fmt "cdo2cmo__x" desc;
Format.fprintf fmt ")@." in
Format.fprintf fmt " match %s with @." name;
List.iter print list
| To_OCaml_bool ->
Format.fprintf fmt " CDuce_all.Value.equal %s CDuce_all.Value.vtrue@." name
| To_OCaml_fun ( lbl, code1, code2 ) ->
Format.fprintf fmt "fun %s -> @." lbl;
Format.fprintf fmt " let cdo2cmo__p = @.";
dump_code fmt lbl code1;
Format.fprintf fmt " in @.";
Format.fprintf fmt " let cdo2cmo__val = @.";
Format.fprintf fmt " try @.";
Format.fprintf fmt " CDuce_all.Eval.eval_apply cdo2cmo__val cdo2cmo__p @.";
Format.fprintf fmt " with CDuce_all.Value.CDuceExn t -> ( @.";
Format.fprintf fmt " match t with @.";
Format.fprintf fmt " | CDuce_all.Value.String_latin1 ( _, _, s, _ ) -> @.";
Format.fprintf fmt " raise ( Error s )@.";
Format.fprintf fmt " | CDuce_all.Value.String_utf8 ( _, _, t, _ ) -> @.";
Format.fprintf fmt " raise ( Error ( @.";
Format.fprintf fmt "CDuce_all.Encodings.Utf8.get_str t ) )@.";
Format.fprintf fmt " | _ -> assert false ) in@.";
dump_code fmt "cdo2cmo__val" code2
| To_OCaml_int ->
Format.fprintf fmt " match CDuce_all.Value.inv_const %s with@." name;
Format.fprintf fmt " | CDuce_all.Types.Integer i -> @.";
Format.fprintf fmt " CDuce_all.Intervals.V.get_int i@.";
Format.fprintf fmt " | _ -> assert false@."
| To_OCaml_list code ->
Format.fprintf fmt " let rec cdo2cmo__seq list = function @.";
Format.fprintf fmt " | CDuce_all.Value.Atom _ -> list@.";
Format.fprintf fmt " | CDuce_all.Value.Pair (cdo2cmo__hd, cdo2cmo__tl) ->@.";
Format.fprintf fmt " let cdo2cmo__hd = ( @.";
dump_code fmt "cdo2cmo__hd" code;
Format.fprintf fmt " ) in cdo2cmo__seq ( list @@ [ cdo2cmo__hd ] ) @.";
Format.fprintf fmt " cdo2cmo__tl @.";
Format.fprintf fmt " | CDuce_all.Value.Concat (cdo2cmo__l1, cdo2cmo__l2) ->@.";
Format.fprintf fmt " ( cdo2cmo__seq list cdo2cmo__l1 ) @@ @.";
Format.fprintf fmt " ( cdo2cmo__seq [] cdo2cmo__l2 )@.";
Format.fprintf fmt " | _ -> assert false in@.";
Format.fprintf fmt " cdo2cmo__seq [] %s@." name
| To_OCaml_string ->
Format.fprintf fmt " CDuce_all.Value.get_string_latin1 %s@." name
| To_OCaml_unit ->
Format.fprintf fmt " ()@."
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_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 ) ->
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
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
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 ->
let list = List.map (
fun ( field, desc ) ->
let d = generate_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 ->
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, Some d
) list in To_CDuce_variant list
| _ -> assert false
and generate_ml_arg ctx = function
| Some lbl -> ctx, lbl
| None -> Ctx.generate_name ctx
and ml_value_slot ctx = Cduce.CompUnit.find_value_slot ( Ctx.comp_unit ctx )
(***********************************************************************************)
let ml_print fmt cu t =
let name = t.ml_name
and desc = t.ml_desc
and kind = t.ml_kind in
let code = generate_ml ( Ctx.create cu ) name desc in dump fmt code
(***********************************************************************************)
module ML : sig
val generate : Format.formatter -> Ocaml.CompUnit.t -> Cduce.CompUnit.t -> unit
end = struct
let generate fmt ml_cu cd_cu =
let mod_name = Cduce.CompUnit.module_name cd_cu in
Format.fprintf fmt "exception Error of string@.";
Format.fprintf fmt "let cdo2cmo__cu = @.";
Format.fprintf fmt " let cdo2cmo__cu = @.";
Format.fprintf fmt " CDuce_all.Types.CompUnit.mk (@.";
Format.fprintf fmt " CDuce_all.Ident.U.mk_latin1 \"%s\") in@." mod_name;
Format.fprintf fmt " CDuce_all.Librarian.import cdo2cmo__cu;@.";
Format.fprintf fmt " CDuce_all.Librarian.run (CDuce_all.Value.sequence []) ";
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 ->
ml_print fmt cd_cu ml_type
| _ -> ()
) ml_cu
end
module ML = Ocaml
module CD = Cduce
let usage = "usage: cdo2cmo [options] file.cmi file.cdo"
(* Get file names. *)
let ml_file, cd_file =
let ml_file = ref None
and cd_file = ref None in
let set_files s = match !ml_file with
| None -> ml_file := Some s
| _ -> cd_file := Some s in
Arg.parse [] set_files usage;
match !ml_file, !cd_file with
| Some f1, Some f2 -> f1, f2
| _ -> Arg.usage [] usage; exit 1
(* Test file extensions. *)
let () =
if not (Filename.check_suffix ml_file ".cmi")
then ( Arg.usage [] usage; exit 1 );
if not (Filename.check_suffix cd_file ".cdo")
then ( Arg.usage [] usage; exit 1 )
(* Create output file name. *)
let out_file =
let out_file = Filename.chop_suffix ml_file ".cmi" in
out_file ^ ".ml"
(* Main function. *)
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
Generator.ML.generate out_fmt ml_cu cd_cu;
close_out out_chan
with
| e -> Format.eprintf "Anomaly: %s\n@." (Printexc.to_string e); exit 2
open Types
(***********************************************************************************)
type error =
| Unsupported_feature of string
exception Error of error
let error e = raise ( Error e )
let report_error err =
let msg = match err with
| Unsupported_feature s ->
"Unsupported " ^ s ^ " in interface file (.mli)"
in
Format.eprintf "%s@." msg
(***********************************************************************************)
module ML = OCaml_all
(***********************************************************************************)
module StringSet = Set.Make( String )
let forward_refs = ref StringSet.empty
(***********************************************************************************)
let rec ml_print fmt name desc = function
| ML_type ->
let () = if StringSet.mem name !forward_refs then
Format.fprintf fmt "and %s = " name
else
Format.fprintf fmt "type %s = " name in
ml_print_desc fmt desc;
Format.fprintf fmt "@.";
forward_refs := StringSet.remove name !forward_refs
| ML_value ->
Format.fprintf fmt "val %s : " name;
ml_print_desc fmt desc;
Format.fprintf fmt "@."
| _ -> ()
and ml_print_desc fmt = function
| ML_core ML_bool -> Format.fprintf fmt "bool"
| ML_core ML_int -> Format.fprintf fmt "int"