(* $Id: rename.ml 1873 2013-07-31 19:11:09Z gerd $
* ----------------------------------------------------------------------
*
*)
open Syntax;;
let name_mapping
~rename_constant
~rename_enum
~rename_type
~rename_union_component
~rename_struct_component
~rename_program
~rename_version
~rename_procedure
dl =
let rec check_type t =
match t with
T_option t' -> check_type t'
| T_array_fixed(_,t') -> check_type t'
| T_array(_,t') -> check_type t'
| T_array_unlimited t' -> check_type t'
| T_enum l ->
List.iter (fun (id,_) -> rename_enum id) l
| T_struct (opts,tdl) ->
if not (List.mem `Tuple opts) then
List.iter (fun td -> rename_struct_component td.decl_symbol) tdl;
List.iter (fun td -> check_type td.decl_type) tdl;
| T_union u ->
let decls =
List.map (fun (_,_,td) -> td) u.cases @
match u.default with Some d -> [d] | None -> [] in
List.iter (fun td -> rename_union_component td.decl_symbol) decls;
List.iter (fun td -> check_type td.decl_type) decls;
| _ ->
()
in
List.iter
(function
Typedef td ->
rename_type td.decl_symbol;
check_type td.decl_type
| Constdef (id,_) ->
rename_constant id
| Progdef p ->
rename_program p.prog_symbol;
List.iter
(fun v ->
rename_version p.prog_symbol v.version_symbol;
List.iter
(fun proc ->
rename_procedure
p.prog_symbol v.version_symbol proc.proc_symbol;
List.iter check_type proc.proc_params;
check_type proc.proc_result
)
v.version_def
)
p.prog_def
)
dl
;;
let reserved =
[ (* Reserved by ocamlrpcgen: *)
"create_client";
"create_portmapped_client";
"create_server";
"create_async_server";
(* O'Caml keywords: *)
"and";
"as";
"assert";
"asr";
"begin";
"class";
"closed";
"constraint";
"do";
"done";
"downto";
"else";
"end";
"exception";
"external";
"false";
"for";
"fun";
"function";
"functor";
"if";
"in";
"include";
"inherit";
"land";
"lazy";
"let";
"lor";
"lsl";
"lsr";
"lxor";
"match";
"method";
"mod";
"module";
"mutable";
"new";
"object";
"of";
"open";
"or";
"parser";
"private";
"rec";
"sig";
"struct";
"then";
"to";
"true";
"try";
"type";
"val";
"virtual";
"when";
"while";
"with";
]
;;
let reserved_table =
let t = Hashtbl.create 100 in
List.iter
(fun n -> Hashtbl.add t n ())
reserved;
t
;;
let simple_name_mapping dl =
(* names of constants => lowercase [value namespace]
* names of enums => lowercase [same namespace as constants]
* names of types => lowercase [type namespace]
* names of union components => Capitalized [no namespace]
* names of struct components => lowercase [component namespace]
* names of programs and versions => Capitalized [==> modules]
* names of procedures => lowercase [value namespace within version module]
*
* names of discriminants do not occur in O'Caml
*)
(* Every list enumerates the names already used: *)
let value_ns = ref [] in
let type_ns = ref [] in
let comp_ns = ref [] in
let module_ns = ref [] in
(* --- ROUND 1: Assign requested names ---------------------------------- *)
let check_lowercase id =
let c = id.ocaml_name.[0] in
if c <> Char.lowercase c then
error ("Name mapping fails for requested O'Caml name `" ^
id.ocaml_name ^ "': name must be lowercase");
in
let check_uppercase id =
let c = id.ocaml_name.[0] in
if c <> Char.uppercase c then
error ("Name mapping fails for requested O'Caml name `" ^
id.ocaml_name ^ "': name must be uppercase");
in
let assign_requested_name ?(prefix = (fun s->s)) ns uc id =
if id.ocaml_name_requested then begin
if Hashtbl.mem reserved_table id.ocaml_name then
error ("Name mapping fails for requested O'Caml name `" ^
id.ocaml_name ^ "': name is reserved");
if List.mem (prefix id.ocaml_name) !ns then
error ("Name mapping fails for requested O'Caml name `" ^
id.ocaml_name ^ "': name has been assigned twice");
(if uc then check_uppercase else check_lowercase) id;
ns := (prefix id.ocaml_name) :: !ns
end
in
let assign_requested_version_name prog_id vers_id =
assign_requested_name
~prefix: (fun n -> prog_id.ocaml_name ^ "." ^ n)
module_ns
true
vers_id
in
let assign_requested_procedure_name prog_id vers_id proc_id =
assign_requested_name
~prefix: (fun n -> prog_id.ocaml_name ^ "." ^
vers_id.ocaml_name ^ "." ^ n)
module_ns
false
proc_id
in
name_mapping
~rename_constant: (assign_requested_name value_ns false)
~rename_enum: (assign_requested_name value_ns false)
~rename_type: (assign_requested_name type_ns false)
~rename_union_component: (fun _ -> ())
~rename_struct_component:(assign_requested_name comp_ns false)
~rename_program: (assign_requested_name module_ns true)
~rename_version: assign_requested_version_name
~rename_procedure: assign_requested_procedure_name
dl;
(* --- ROUND 2: Map other names somehow --------------------------------- *)
let get_lowercase id = String.lowercase id.xdr_name in
let get_uppercase id = String.capitalize id.xdr_name in
let map_name ?(prefix = (fun s -> s)) ns uc id =
if not id.ocaml_name_requested then begin
let n = ref ((if uc then get_uppercase else get_lowercase) id) in
let renamed = ref false in
while List.mem (prefix !n) !ns || Hashtbl.mem reserved_table !n do
n := !n ^ "'";
renamed := true
done;
if !renamed then
prerr_endline("Warning: Renamed \"" ^
prefix id.xdr_name ^ "\" to \"" ^
prefix !n ^ "\"");
id.ocaml_name <- !n;
ns := (prefix !n) :: !ns
end
in
let map_version_name prog_id vers_id =
map_name
~prefix: (fun n -> prog_id.ocaml_name ^ "." ^ n)
module_ns
true
vers_id
in
let map_procedure_name prog_id vers_id proc_id =
map_name
~prefix: (fun n -> prog_id.ocaml_name ^ "." ^
vers_id.ocaml_name ^ "." ^ n)
module_ns
false
proc_id
in
let retain_name id =
if not id.ocaml_name_requested then
id.ocaml_name <- id.xdr_name
in
name_mapping
~rename_constant: (map_name value_ns false)
~rename_enum: (map_name value_ns false)
~rename_type: (map_name type_ns false)
~rename_union_component: retain_name
~rename_struct_component:(map_name comp_ns false)
~rename_program: (map_name module_ns true)
~rename_version: map_version_name
~rename_procedure: map_procedure_name
dl;
;;
