Commit 30a65471 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-03-09 20:01:46 by jdemouth] cdo2cmo is now included in cduce compiler.

Original author: jdemouth
Date: 2004-03-09 20:01:46+00:00
parent 1e50c8bc
ifdef ML_INTERFACE then
open Ml_types
ifdef ML_INTERFACE then
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
ifdef ML_INTERFACE then
let translations = Translations.create 17
(***********************************************************************************)
ifdef ML_INTERFACE then
let cd_type_nil =
let nil = Atoms.atom ( Atoms.V.mk_ascii "nil" ) in
Types.atom nil
ifdef ML_INTERFACE then
let rec from_ocaml_rec left array = function
| { ml_id = id; ml_kind = ML_type; ml_decl = decl } ->
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 = Types.make () in
Translations.add translations id node;
let desc = from_decl left array decl in
Types.define node desc;
node
and from_decl left array = function
| ML_abstract desc ->
Types.descr ( from_desc left array desc )
| ML_record list ->
let list = List.map (
fun ( name, desc ) ->
let name_ns = Ns.mk_ascii "" in
let name_val = Encodings.Utf8.mk name in
let desc = from_desc left array desc in
( name_ns, name_val ), Types.descr desc
) list in
Types.rec_of_list ~opened:left list
| ML_variant list ->
List.fold_left (
fun t ( name, list ) ->
let node = Types.make () in
let atom = Atoms.atom ( Atoms.V.mk_ascii name ) in
Types.define node ( Types.atom atom );
let desc = match list with
| [] ->
Types.descr node
| hd :: [] ->
let desc = from_desc left array hd in
Types.times node desc
| _ ->
let tuple = tuple_of_list left array list in
Types.times node tuple
in
Types.cup t desc
) Types.empty list
| ML_nil -> assert false
and from_desc left array = function
| ML_arrow ( lbl, d1, d2 ) ->
let node = Types.make () in
let l = from_desc true array d1
and r = from_desc false array d2 in
Types.define node ( Types.arrow l r );
node
| ML_bool ->
let node = Types.make () in
Types.define node ( Builtin_defs.bool );
node
| ML_char ->
let node = Types.make () in
Types.define node ( Types.char ( 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 = Types.make () in
let lB = Intervals.V.mk ( string_of_int min_int )
and uB = Intervals.V.mk ( string_of_int max_int ) in
Types.define node ( Types.interval ( Intervals.bounded lB uB ) );
node
| ML_list d ->
let desc = from_desc left array d in
Sequence.star_node desc
| ML_option desc ->
let node = Types.make () in
let trans = Types.descr ( from_desc left array desc ) in
Types.define node ( Types.cup trans cd_type_nil );
node
| ML_reference desc ->
let node = 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
Types.define node ( from_decl left array ref );
node
| ML_string ->
let node = Types.make () in
Types.define node ( Builtin_defs.string_latin1 );
node
| ML_tuple list ->
assert ( List.length list >= 2 );
tuple_of_list left array list
| ML_unit ->
let node = Types.make () in
Types.define node 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 = Types.make () in
let desc = from_desc left array hd in
Types.define node ( Types.times tail desc );
node
| hd :: tl ->
let node = Types.make () in
let desc = from_desc left array hd in
Types.define node ( 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 )
(***********************************************************************************)
ifdef ML_INTERFACE then
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 = Types.Print.print
let is_subtype t1 t2 = Types.subtype t1 t2
end
(***********************************************************************************)
ifdef ML_INTERFACE then
module CompUnit : sig
type t
val from_types_cu : string -> Types.CompUnit.t -> 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: Types.CompUnit.t;
cu_typer: Typer.t; }
let from_types_cu mod_name cu =
let ty = !( Typer.from_comp_unit ) cu in
{ cu_mod = mod_name; cu_unit = cu; cu_typer = ty }
let from_bytecode file_name =
let mod_name = Filename.chop_suffix file_name ".cdo" in
let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 mod_name ) in
Librarian.import cu;
let ty = !( Typer.from_comp_unit ) cu in
{ cu_mod = mod_name; cu_unit = cu; cu_typer = ty }
let find_type cu name =
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
Typer.find_type id cu.cu_typer
let find_value cu name =
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
Typer.find_value id cu.cu_typer
let find_value_slot cu ( name : string ) =
let cu = cu.cu_unit in
let env = !Compile.from_comp_unit cu in
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
let f_slot = Compile.find id env in
match f_slot with Lambda.Global i -> i
| _ -> assert false
let module_name cu = cu.cu_mod
end;;
ifdef ML_INTERFACE then
type error =
| Undefined_value of string * string
| Type_mismatch of string * Ml_ocaml.Type.t * Ml_cduce.Type.t
ifdef ML_INTERFACE then
exception Error of error
ifdef ML_INTERFACE then
let error e = raise ( Error e )
ifdef ML_INTERFACE then
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;
Ml_cduce.Type.print Format.err_formatter cd_t;
Format.eprintf "\nis not a subtype of@.";
Ml_ocaml.Type.print Format.err_formatter ( true, [ ml_t ] )
(***********************************************************************************)
ifdef ML_INTERFACE then
let run ml_cu cd_cu =
let file = Ml_cduce.CompUnit.module_name cd_cu in
try Ml_ocaml.CompUnit.iter (
fun ( _, list ) -> match list with
| [ { Ml_types.ml_kind = Ml_types.ML_value } as ml_t ] -> (
try
let cd_type = Ml_cduce.Type.from_ocaml ml_t
and cd_base = Ml_cduce.CompUnit.find_value cd_cu ml_t.Ml_types.ml_name in
if not ( Ml_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.Ml_types.ml_name ) ) )
| _ -> ()
) ml_cu
with Error e -> report_error e; exit 1
This diff is collapsed.
ifdef ML_INTERFACE
let ocaml_support = true
else
let ocaml_support = false
ifdef ML_INTERFACE then
open Ml_types
(***********************************************************************************)
ifdef ML_INTERFACE then
type error =
| Unsupported_feature of string
ifdef ML_INTERFACE then
exception Error of error
ifdef ML_INTERFACE then
let error e = raise ( Error e )
ifdef ML_INTERFACE then
let report_error err =
let msg = match err with
| Unsupported_feature s ->
"cdo2cmo : error unsupported " ^ s ^ " in interface file (.mli)"
in
Format.eprintf "%s@." msg
(***********************************************************************************)
ifdef ML_INTERFACE then
module ML = OCaml_all
(***********************************************************************************)
ifdef ML_INTERFACE then
let recursive_type = ref false
(***********************************************************************************)
ifdef ML_INTERFACE then
let rec ml_print_list fmt separator f = function
| [] -> assert false
| hd :: [] -> f fmt hd
| hd :: tl ->
f fmt hd;
Format.fprintf fmt "%s" separator;
ml_print_list fmt separator f tl
ifdef ML_INTERFACE then
let rec ml_print fmt is_rec name decl = function
| ML_type ->
let () = if is_rec then Format.fprintf fmt "and %s = " name
else Format.fprintf fmt "type %s = " name in
ml_print_decl fmt decl;
Format.fprintf fmt "@."
| ML_value ->
Format.fprintf fmt "val %s : " name;
ml_print_decl fmt decl;
Format.fprintf fmt "@."
| ML_module list ->
Format.fprintf fmt "module %s : sig @." name;
List.iter (
fun t -> ml_print fmt false t.ml_name t.ml_decl t.ml_kind
) list;
Format.fprintf fmt "end@."
and ml_print_decl fmt = function
| ML_abstract desc -> ml_print_desc fmt desc
| ML_record list ->
Format.fprintf fmt "{ ";
ml_print_list fmt "; " (
fun fmt ( name, desc ) ->
Format.fprintf fmt "%s: " name;
ml_print_desc fmt desc
) list;
Format.fprintf fmt " }"
| ML_variant list ->
ml_print_list fmt " | " (
fun fmt ( name, list ) -> match list with
| [] -> Format.fprintf fmt "%s" name
| hd :: [] ->
Format.fprintf fmt "%s of " name;
ml_print_desc fmt hd
| list ->
Format.fprintf fmt "%s of " name;
ml_print_list fmt " * " ml_print_desc list
) list
| _ -> assert false
and ml_print_desc fmt = function
| ML_arrow ( None, d1, d2 ) ->
Format.fprintf fmt "( ";
ml_print_desc fmt d1;
Format.fprintf fmt " ) -> ";
ml_print_desc fmt d2
| ML_arrow ( Some lbl, d1, d2 ) ->
Format.fprintf fmt "%s:( " lbl;
ml_print_desc fmt d1;
Format.fprintf fmt " ) -> ";
ml_print_desc fmt d2
| ML_bool -> Format.fprintf fmt "bool"
| ML_char -> Format.fprintf fmt "char"
| ML_ident ( name, [||], _ ) ->
Format.fprintf fmt "%s" name
| ML_ident ( name, array, _ ) ->
Format.fprintf fmt "( ";
let le = ( Array.length array ) - 1 in
for i = 0 to le do
ml_print_desc fmt array.( i );
if i < le then Format.fprintf fmt ","
done;
Format.fprintf fmt " ) %s" name
| ML_int -> Format.fprintf fmt "int"
| ML_list desc ->
ml_print_desc fmt desc;
Format.fprintf fmt " list"
| ML_option desc ->
ml_print_desc fmt desc;
Format.fprintf fmt " option"
| ML_reference desc ->
ml_print_desc fmt desc;
Format.fprintf fmt " ref"
| ML_string -> Format.fprintf fmt "string"
| ML_tuple list ->
Format.fprintf fmt "(";
ml_print_list fmt " * " ml_print_desc list;
Format.fprintf fmt ")"
| ML_unit -> Format.fprintf fmt "unit"
| ML_var id -> Format.fprintf fmt "(%d)" id
(***********************************************************************************)
ifdef ML_INTERFACE then
module Type : sig
type t = ocaml_t
val print : Format.formatter -> ( bool * t list )-> unit
end = struct
type t = ocaml_t;;
let print fmt ( need, list ) =
let rec internal is_rec = function
| [ t ] ->
ml_print fmt is_rec t.ml_name t.ml_decl t.ml_kind
| t::tl ->
ml_print fmt is_rec t.ml_name t.ml_decl t.ml_kind;
internal true tl
| _ -> ()
in
if need then internal false list else ()
end
(***********************************************************************************)
ifdef ML_INTERFACE then
module Path = struct
type t = string list * string
(* [append path name] append [name] to the end of [path]. *)
let append (list,last) name = (list @ [ last ], name)
(* [create list name] create a path from a [list] and a [name]. *)
let create list name = list, name
(* [from_string string] create a path from [string]. *)
let from_string string =
let rec from_string_rec :
string list -> string -> string list * string option =
fun tail str ->
try
let idx = String.index str '.' in
let tmp = String.sub str 0 idx in
let idx = idx + 1 in
let res = String.sub str idx ((String.length str) - idx) in
let p,o = from_string_rec (tail @ [ tmp ]) res in
p, None
with Not_found -> tail, Some str
in
let path,name = from_string_rec [] string in
let name = match name with Some s -> s | None -> assert false in
path, name
(* Get path head. *)
let head ( list, last ) = List.hd list
(* Get path length. *)
let length ( list, last ) = 1 + ( List.length list )
(* [prepend path name] prepend [name] to the beginning of [path]. *)
let prepend ( list,last ) name = ( name :: list, last )
(* Remove path queue. *)
let remove_end ( list, last ) =
let rec internal tail = function
| [ x ] -> tail, x
| hd :: tl -> internal ( tail @ [ hd ] ) tl
| _ -> assert false in
let list, path = internal [] list in
list, path
(* [to_string path] translate [path] to string. *)
let to_string ( path, name ) =
let sub =
List.fold_left (fun prev str -> prev ^ str ^ "_") "" path in
sub ^ name
end
(***********************************************************************************)
ifdef ML_INTERFACE then
module Env = struct
(* Set of forward references. *)
module StringSet = Set.Make ( String )
(* Map of local types. *)
module StringMap = Map.Make ( String )
(* Main type. *)
type t =
{ (* Current module path. *)
env_path: Path.t;
(* List of values. *)
env_list: ( bool * ocaml_t list ) list;
(* Type queue to merge recursive types. *)
env_queue: ocaml_t list;
(* Local environment. *)
env_local: string StringMap.t;
(* Global table containing all types. *)
env_global: ( string, ocaml_t ) Hashtbl.t;
(* Forward references. *)
env_forward: StringSet.t;
(* Are we dealing with external module. *)
env_external: bool;
(* Parameters table. *)
env_parameters: ( int, int ) Hashtbl.t }
(* Create an empty environment. *)
let current name =
{ env_path = Path.from_string name;
env_list = [];
env_queue = [];
env_local = StringMap.empty;
env_global = Hashtbl.create 17;
env_forward = StringSet.empty;
env_external = false;
env_parameters = Hashtbl.create 17 }
(* Create an external environment. *)
let external_env env name =
{ env with
env_path = Path.from_string name;
env_list = [];
env_queue = [];
env_local = StringMap.empty;
env_forward = StringSet.empty;
env_external = true;
env_parameters = Hashtbl.create 17 }
(* Add a pair to the environment. *)
let rec add env = function
| { ml_id = id; ml_name = name; ml_kind = ML_type } as value ->
{ env with
env_queue = env.env_queue @ [ value ];
env_local = StringMap.add name id env.env_local }
| { ml_name = name; ml_kind = ML_value } as value ->
let len = Path.length env.env_path = 1 in
let list = env.env_list @ [ len, [ value ] ] in
{ env with env_list = list }
| value ->
let len = Path.length env.env_path = 1 in
let list = env.env_list @ [ len, [ value ] ] in
{ env with env_list = list }
(* Add a forward reference. *)
let add_forward_ref env name =
{ env with env_forward = StringSet.add name env.env_forward }
(* Add a new parameter mapping. *)
let add_parameter env id cnt = Hashtbl.add env.env_parameters id cnt
(* Get current module path. *)
let current_path env = env.env_path
(* Get type in local environment. *)
let find_local env key = try
StringMap.find key env.env_local
with Not_found ->
Path.to_string ( Path.append env.env_path key )
(* Get parameter value. *)
let find_parameter env id = try
Hashtbl.find env.env_parameters id
with Not_found -> id
(* Get type in global environment. *)
let find_type env id name = try
Hashtbl.find env.env_global id
with Not_found ->
let node =
{ ml_id = id;
ml_name = name;
ml_kind = ML_type;
ml_rec = false;
ml_decl = ML_nil } in
Hashtbl.add env.env_global node.ml_id node;
node
(* Flush recursive type buffer. *)
let flush_types env = match env.env_queue with
| [] -> env
| values ->
let len = Path.length env.env_path = 1 in
{ env with
env_list = env.env_list @ [ len, values ];
env_queue = [] }
(* Is there any forward reference. *)
let has_forward_ref env = not ( StringSet.is_empty env.env_forward )
(* Are we treating local file. *)
let is_file_local env = not env.env_external
(* Is there a type in global environment called ... *)
let mem_type env = Hashtbl.mem env.env_global
(* Add a module to module path. *)
let push_module env name =
{ env with env_path = Path.append env.env_path name }
(* Pop top module. *)
let pop_module env =
{ env with env_path = Path.remove_end env.env_path }
(* Remove forward reference. *)
let remove_forward_ref env name =
{ env with env_forward = StringSet.remove name env.env_forward }
(* Get an environment without parameters. *)
let without_parameters env = { env with env_parameters = Hashtbl.create 17 }
end
(***********************************************************************************)
ifdef ML_INTERFACE then
(* Translate internal OCaml compiler Path.t to our Path.t *)
let path_to_mlpath path =
let rec internal_rec tail = function
| ML.Path.Pident id -> (ML.Ident.name id) :: tail
| ML.Path.Pdot (p,id,_) -> internal_rec (id::tail) p
| _ -> failwith "path_to_mlpath : Papply -- (2)" in
match path with
| ML.Path.Pident id -> [], ML.Ident.name id
| ML.Path.Pdot (p,id,_) -> internal_rec [] p, id
| _ -> failwith "path_to_mlpath : Papply -- (1)"
(***********************************************************************************)
ifdef ML_INTERFACE then
let rec translate_ident env path spath = function
| [] when spath = "bool" -> env, ML_bool
| [] when spath = "char" -> env, ML_char
| [] when spath = "int" -> env, ML_int
| [] when spath = "string" -> env, ML_string
| [] when spath = "unit" -> env, ML_unit
| [] ->
let env, node = match path with
| ML.Path.Pident _ ->
let env, node =
let lpath = Env.find_local env spath in
match Env.find_type env lpath spath with
| { ml_decl = ML_nil } as node ->
Env.add_forward_ref env spath, node
| node -> env, node in
env, node
| ML.Path.Pdot _ ->
let mde = ML.Ident.name ( ML.Path.head path ) in
if not ( Env.mem_type env spath ) then load_module env mde;
let node = Env.find_type env spath spath in
env, node