1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
|
(***********************************************************************)
(* *)
(* CamlIDL *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0 *)
(* *)
(***********************************************************************)
(* $Id: fixlabels.ml,v 1.4 2001/06/17 10:50:24 xleroy Exp $ *)
(* Prefix record labels with struct/typedef name if required or requested *)
open Printf
open Utils
open Idltypes
open Typedef
open Funct
open Intf
open File
(* Determine if an mlname was provided by the user in the IDL file *)
let no_ml_name f = f.field_mlname == f.field_name
(* We use physical equality instead of string equality
so that an explicit [mlname(samename)] can override the prefixing *)
(* Collect all label names and those that appear at least twice *)
module LabelSet = Set.Make(struct type t = string let compare = compare end)
let all_labels = ref LabelSet.empty
let repeated_labels = ref LabelSet.empty
let add_label s =
if LabelSet.mem s !all_labels then
repeated_labels := LabelSet.add s !repeated_labels
else
all_labels := LabelSet.add s !all_labels
let rec collect_type = function
Type_pointer(_, ty) -> collect_type ty
| Type_array(_, ty) -> collect_type ty
| Type_bigarray(_, ty) -> collect_type ty
| Type_struct sd -> List.iter collect_field sd.sd_fields
| Type_union(ud, _) -> List.iter collect_case ud.ud_cases
| Type_const ty -> collect_type ty
| _ -> ()
and collect_field f =
if no_ml_name f then add_label f.field_name;
collect_type f.field_typ
and collect_case c =
match c.case_field with None -> () | Some f -> collect_field f
let collect_component = function
Comp_typedecl td -> collect_type td.td_type
| Comp_structdecl sd -> List.iter collect_field sd.sd_fields
| Comp_uniondecl ud -> List.iter collect_case ud.ud_cases
| Comp_fundecl fd -> collect_type fd.fun_res
| Comp_interface intf ->
List.iter (fun fd -> collect_type fd.fun_res) intf.intf_methods
| _ -> ()
(* A struct definition needs prefixing if some of its labels occur
several times in the file *)
let need_prefixing sd =
List.exists
(fun f -> no_ml_name f && LabelSet.mem f.field_name !repeated_labels)
sd.sd_fields
(* Prefix label names with struct or typedef name, if required or requested *)
let choose_prefix oldpref newpref =
if newpref <> "" then newpref else oldpref
let rec prefix_type pref = function
Type_struct sd -> Type_struct(prefix_struct pref sd)
| Type_union(ud, attr) -> Type_union(prefix_union pref ud, attr)
| Type_pointer(kind, ty) -> Type_pointer(kind, prefix_type pref ty)
| Type_array(attr, ty) -> Type_array(attr, prefix_type pref ty)
| Type_const ty -> Type_const(prefix_type pref ty)
| ty -> ty
and prefix_struct pref sd =
let prefix = choose_prefix pref sd.sd_name in
let add_prefix =
if !Clflags.prefix_all_labels || need_prefixing sd then begin
if prefix = "" then begin
eprintf "Warning: couldn't find prefix for anonymous struct\n";
false
end else
true
end else
false in
{sd with sd_fields = List.map (prefix_field add_prefix prefix) sd.sd_fields}
and prefix_field add_prefix pref f =
let new_mlname =
if add_prefix && no_ml_name f
then pref ^ "_" ^ f.field_name
else f.field_mlname in
{f with field_mlname = new_mlname;
field_typ = prefix_type pref f.field_typ}
and prefix_union pref ud =
let prefix = choose_prefix pref ud.ud_name in
{ud with ud_cases = List.map (prefix_case prefix) ud.ud_cases}
and prefix_case pref cs =
match cs.case_field with
None -> cs
| Some ty -> {cs with case_field = Some(prefix_field false pref ty)}
let prefix_typedecl td =
{td with td_type = prefix_type td.td_name td.td_type}
let prefix_fundecl fd =
{fd with fun_res = prefix_type "" fd.fun_res}
(* no struct decl in function arguments *)
let prefix_interface intf =
{intf with intf_methods = List.map prefix_fundecl intf.intf_methods}
let prefix_component = function
Comp_typedecl td -> Comp_typedecl(prefix_typedecl td)
| Comp_structdecl sd -> Comp_structdecl(prefix_struct "" sd)
| Comp_uniondecl ud -> Comp_uniondecl(prefix_union "" ud)
| Comp_fundecl fd -> Comp_fundecl(prefix_fundecl fd)
| Comp_interface intf -> Comp_interface(prefix_interface intf)
| cmp -> cmp
let prefix_file f =
if !Clflags.keep_labels then f else begin
all_labels := LabelSet.empty;
repeated_labels := LabelSet.empty;
List.iter collect_component f;
let res = List.map prefix_component f in
all_labels := LabelSet.empty;
repeated_labels := LabelSet.empty;
res
end
|