[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

cdo2cmo/ml_cduce.ml

+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;;

cdo2cmo/ml_checker.ml

+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

cdo2cmo/ml_interface.ml

+ifdef ML_INTERFACE
+  let ocaml_support = true
+else
+  let ocaml_support = false

cdo2cmo/ml_ocaml.ml

+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