Skip to content

GitLab

Commit 8c1f05c6 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-03-09 20:07:50 by jdemouth] Empty log message 

Original author: jdemouth
Date: 2004-03-09 20:09:23+00:00
parent 7d6a9be9
Hide whitespace changes
Inline Side-by-side
cdo2cmo/INSTALL deleted 100644 → 0
View file @ 7d6a9be9
#
# cdo2cmo extension by Julien Demouth
#
If you install all your sources in /usr/local/src/ then
1) Go in the directory of ocaml sources
cd /usr/local/src/ocaml-3.07
2) apply the patch
patch -p1 < /<source_path>/cduce/cdo2cmo/ocaml_cdo2cmo_patch
3) Optional (if your version of Ocaml is 3.07-pl2 you do not need it)
make and install ocaml as usual and recompile at least all the
ocaml libraries used by cduce
4) Create the library OCaml_all and install it, this is done by running
in the (patched) ocaml source the following command
make install_liball
and optionally
make install_liball.opt
5) Create the cduce2ocaml binary by running from the root of CDuce source tree:
make cduce2ocaml
Now look at the README file to see how to use the command cduce2ocaml.
cdo2cmo/src/cduce.ml deleted 100644 → 0
View file @ 7d6a9be9
open Types
(***********************************************************************************)
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_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 left array desc in
( name_ns, name_val ), CD.Types.descr desc
) list in
CD.Types.rec_of_list ~opened:left list
| ML_variant list ->
List.fold_left (
fun t ( name, list ) ->
let node = CD.Types.make () in
let atom = CD.Atoms.atom ( CD.Atoms.V.mk_ascii name ) in
CD.Types.define node ( CD.Types.atom atom );
let desc = match list with
| [] ->
CD.Types.descr node
| hd :: [] ->
let desc = from_desc left array hd in
CD.Types.times node desc
| _ ->
let tuple = tuple_of_list left array list in
CD.Types.times node 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 node = CD.Types.make () in
let l = from_desc true array d1
and r = from_desc false array d2 in
CD.Types.define node ( CD.Types.arrow l r );
node
| ML_bool ->
let node = CD.Types.make () in
CD.Types.define node ( CD.Builtin_defs.bool );
node
| ML_char ->
let node = CD.Types.make () in
CD.Types.define node ( CD.Types.char ( CD.Chars.mk_classes [ ( 0, 255 ) ] ) );
node
| ML_ident ( id, params, ocaml ) ->
from_ocaml_type left params ocaml.ml_id ocaml.ml_decl
| ML_int ->
let node = CD.Types.make () in
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.define node ( CD.Types.interval ( CD.Intervals.bounded lB uB ) );
node
| ML_list d ->
let desc = from_desc left array d in
CD.Sequence.star_node desc
| ML_option desc ->
let node = CD.Types.make () in
let trans = CD.Types.descr ( from_desc left array desc ) in
CD.Types.define node ( CD.Types.cup trans cd_type_nil );
node
| ML_reference desc ->
let node = CD.Types.make () in
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.define node ( from_decl left array ref );
node
| ML_string ->
let node = CD.Types.make () in
CD.Types.define node ( CD.Builtin_defs.string_latin1 );
node
| ML_tuple list ->
assert ( List.length list >= 2 );
tuple_of_list left array list
| ML_unit ->
let node = CD.Types.make () in
CD.Types.define node CD.Sequence.nil_type;
node
| ML_var id ->
from_desc left array array.( id )
and tuple_of_list left array list =
let rec internal tail = function
| hd :: [] ->
let node = CD.Types.make () in
let desc = from_desc left array hd in
CD.Types.define node ( CD.Types.times tail desc );
node
| hd :: tl ->
let node = CD.Types.make () in
let desc = from_desc left array hd in
CD.Types.define node ( CD.Types.times tail desc );
internal node tl
| [] -> assert false in
let tail = from_desc left array ( List.hd list ) in
internal tail ( List.tl list )
(***********************************************************************************)
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 ocaml = from_ocaml_rec true [||] ocaml
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
cdo2cmo/src/checker.ml deleted 100644 → 0
View file @ 7d6a9be9
(***********************************************************************************)
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 "cdo2cmo : 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 "cdo2cmo : 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 ( true, [ ml_t ] )
(***********************************************************************************)
let run ml_cu cd_cu =
let file = Cduce.CompUnit.module_name cd_cu in
try Ocaml.CompUnit.iter (
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
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
cdo2cmo/src/generator.ml deleted 100644 → 0
View file @ 7d6a9be9
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_char
| 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_type of string
| To_CDuce_unit
| To_CDuce_variant of ( string * code_t list ) list
| To_OCaml_bool
| To_OCaml_char
| 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 list ) 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;
Format.fprintf fmt "@."
| 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;
Format.fprintf fmt "@."
| 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_char ->
assert false (* TODO *)
| 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_type id ->
Format.fprintf fmt "ocaml2cduce__%s %s" id name
| To_CDuce_variant list ->
let rec print_proj n m =
if n < m then begin
Format.fprintf fmt "cdo2cmo__v%d" n;
if ( n + 1 ) < m then Format.fprintf fmt ", ";
print_proj ( n + 1 ) m
end; in
let rec print_list n = function
| [ cde ] ->
dump_code fmt "cdo2cmo__v0" cde
| d1 :: [ d2 ] ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" n ) d1;
Format.fprintf fmt ", ";
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" ( n + 1 ) ) d2;
Format.fprintf fmt ")@."
| d1 :: tl ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" n ) d1;
Format.fprintf fmt ", ";
print_list ( n + 1 ) tl;
Format.fprintf fmt ")@."
| _ -> assert false in
let print ( label, list ) = match list with
| [] ->
Format.fprintf fmt "| %s -> @." label;
Format.fprintf fmt "CDuce_all.Value.Atom ( @.";
Format.fprintf fmt "CDuce_all.Atoms.V.mk_ascii \"%s\" )@." label;
| list ->
Format.fprintf fmt "| %s ( " label;
print_proj 0 ( List.length list );
Format.fprintf fmt " ) -> @.";
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;
print_list 0 list;
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_char ->
assert false (* TODO *)
| 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_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_proj n m =
if n < m then begin
Format.fprintf fmt "cdo2cmo__v%d" n;
if n + 1 < m then Format.fprintf fmt ",@.";
print_proj ( n + 1 ) m
end; in
let rec print_list = function
| [] ->
Format.fprintf fmt " | _ -> assert false @."
| ( field, [] ) :: tl ->
Format.fprintf fmt " | \"%s\" -> %s@." field field;
print_list tl
| ( field, list ) :: tl ->
Format.fprintf fmt " | \"%s\" -> ( @." field;
let cnt = ref 0 in
List.iter (
fun desc ->
Format.fprintf fmt "let cdo2cmo__v%d = @." !cnt;
dump_code fmt "cdo2cmo__desc" desc;
Format.fprintf fmt "in@.";
incr cnt
) list;
Format.fprintf fmt "%s ( " field;
print_proj 0 ( List.length list );
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.Atom cdo2cmo__atom -> @.";
Format.fprintf fmt " cdo2cmo__atom, CDuce_all.Value.nil @.";
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@.";