(* $Id: syntax.ml 1871 2013-07-30 22:13:52Z gerd $
* ----------------------------------------------------------------------
*)
open Netnumber;;
open Printf
exception Error of string;;
let error s = raise(Error s);;
type xdr_id =
{ xdr_name : string;
ocaml_name_requested : bool;
mutable ocaml_name : string;
}
;;
type mangling_option =
[ `Lowercase
| `Uppercase
| `Capitalize
| `Prefix of string
]
;;
let mk_id name =
{ xdr_name = name; ocaml_name_requested = false; ocaml_name = "" }
;;
let mk_mapped_id xdrname ocamlname =
{ xdr_name = xdrname; ocaml_name_requested = true; ocaml_name = ocamlname }
;;
let mk_void_id () =
{ xdr_name = ""; ocaml_name_requested = false; ocaml_name = "" }
;;
let mangle_name opts name =
List.fold_left
(fun name opt ->
match opt with
| `Lowercase -> String.lowercase name
| `Uppercase -> String.uppercase name
| `Capitalize -> String.capitalize name
| `Prefix p -> p ^ name
)
name
opts
;;
let mangle_id ?(remap=false) opts id =
(* remap: only true for the second round of mangling of union cases.
As we want to map the cases independently of the base enum, we ignore
the ocaml_name for the base enum.
*)
if remap then (
if opts <> [] then
{ id with
ocaml_name = mangle_name opts id.xdr_name;
ocaml_name_requested = true;
}
else
{ id with
ocaml_name = String.lowercase id.xdr_name;
ocaml_name_requested = false;
}
)
else (
if opts <> [] && not id.ocaml_name_requested then
{ id with
ocaml_name = mangle_name opts id.xdr_name;
ocaml_name_requested = true;
}
else
id
)
;;
type xdr_constant =
| Constant of (bool * uint4) (* sign (true=neg), absolute value *)
| Named_constant of string
;;
let constant c =
match c with
Constant(sign,v) -> (sign,v)
| Named_constant _ -> assert false
;;
type int_variant =
| Abstract
| INT32
| INT64
| Unboxed
;;
type struct_option =
[ `Tuple
| `Equals of string
]
;;
type xdr_type =
T_opaque_fixed of xdr_constant ref
| T_opaque of xdr_constant ref
| T_opaque_unlimited
| T_string of xdr_constant ref
| T_string_unlimited
| T_mstring of string * xdr_constant ref
| T_mstring_unlimited of string
| T_option of xdr_type
| T_void
| T_array_fixed of (xdr_constant ref * xdr_type)
| T_array of (xdr_constant ref * xdr_type)
| T_array_unlimited of xdr_type
| T_int of int_variant
| T_uint of int_variant
| T_hyper of int_variant
| T_uhyper of int_variant
| T_double
| T_float
| T_bool
| T_refer_to of (refconstr * string ref) (* always the XDR name! *)
| T_enum of (xdr_id * xdr_constant ref) list
| T_struct of (struct_option list * xdr_decl list)
| T_union of xdr_union
and refconstr =
R_struct
| R_union
| R_enum
| R_any
and xdr_union =
{ discriminant : xdr_decl;
cases : (xdr_constant ref * string option * xdr_decl) list;
(* List of (c, ocaml_name, component_decl)
* E.g. case ENUM_CASE => ocaml_name: t x;
* c: The constant before ':' (ENUM_CASE)
* ocaml_name: The ocaml name for the polymorphic variant
* component_decl: The declaration after ':' (t x)
*)
mangling : mangling_option list;
(* Additional mangling for [cases]. This is delayed because
[discrimant] can be a reference.
*)
default : xdr_decl option;
}
and xdr_decl =
{ decl_type : xdr_type;
decl_symbol : xdr_id;
mutable decl_direct : bool; (* whether direct mapping is possible here *)
}
;;
type xdr_prog =
{ prog_symbol : xdr_id;
prog_def : xdr_version list;
prog_number : uint4;
}
and xdr_version =
{ version_symbol : xdr_id;
version_def : xdr_proc list;
version_number : uint4;
}
and xdr_proc =
{ proc_symbol : xdr_id;
proc_params : xdr_type list;
proc_result : xdr_type;
proc_number : uint4;
}
;;
type xdr_def =
Typedef of xdr_decl
| Constdef of (xdr_id * (bool * uint4))
| Progdef of xdr_prog
;;
let mk_enum ?remap (opts:mangling_option list) l =
List.map
(fun (id,const) ->
(mangle_id ?remap opts id,const)
)
l
let mk_decl id t =
{ decl_type = t;
decl_symbol = id;
decl_direct = false; (* initially *)
}
;;
let mk_union opts discr cs defl =
{ discriminant = discr;
cases = cs;
mangling = opts;
default = defl;
}
;;
let mangling_opt opt =
match opt with
| #mangling_option as opt -> [opt]
| _ -> []
let struct_opt opt =
match opt with
| #struct_option as opt -> [opt]
| _ -> []
let mk_struct opts decls =
let mangling_opts =
List.flatten (List.map mangling_opt opts) in
let struct_opts =
List.flatten (List.map struct_opt opts) in
let decls1 =
List.map
(fun d ->
{ d with decl_symbol = mangle_id mangling_opts d.decl_symbol }
)
decls in
(struct_opts, decls1)
;;
let mk_program symbol def number =
{ prog_symbol = symbol;
prog_def = def;
prog_number = number;
}
;;
let mk_version symbol def number =
{ version_symbol = symbol;
version_def = def;
version_number = number;
}
;;
let mk_procedure symbol params result number =
{ proc_symbol = symbol;
proc_params = params;
proc_result = result;
proc_number = number;
}
;;
let submax s i n =
let l = String.length s in
let n' = min (l-i) n in
String.sub s i n'
;;
let constant_of_string s =
(* s: 32 bit integer in C syntax, i.e:
* 0x...: hex number
* 0...: octal number
* [1-9]...: decimal number
* Returns the number as uint4.
*)
assert(String.length s >= 1);
let sign, i0 =
match submax s 0 1 with
"-" -> true, 1
| "+" -> false, 1
| _ -> false, 0
in
let base, i1 =
match submax s i0 2 with
("0x"|"0X") -> 16, i0+2
| _ ->
(match submax s i0 1 with
"0" -> 8, i0+1
| _ -> 10, i0
)
in
let m = Int64.of_string "0xffffffff" in
let base64 = Int64.of_int base in
let n = ref (Int64.zero) in
for i = i1 to String.length s - 1 do
let c = s.[i] in
let v =
match c with
| '0'..'9' -> Char.code c - 48
| 'a'..'f' -> Char.code c - Char.code 'a' + 10
| 'A'..'F' -> Char.code c - Char.code 'A' + 10
| _ -> assert false
in
assert (v < base);
n := Int64.add (Int64.mul !n base64) (Int64.of_int v);
if !n > m then
error ("Number too big: " ^ s);
done;
(sign, uint4_of_int64 !n)
;;
let string_of_uint4 n =
let n' = int64_of_uint4 n in
Int64.to_string n'
;;
(**********************************************************************)
let resolve_constants dl =
(* Iterates over all subterms of dl, and processes all constant definitions
* (including enums).
* Furthermore, all references to defined constants (Named_constant) are
* replaced by the values (Constant) of the constants.
*)
let constmap = Hashtbl.create 100 in
let def_constant id c =
try
ignore(Hashtbl.find constmap id.xdr_name);
error("The constant `" ^ id.xdr_name ^ "' is already defined")
with
Not_found ->
Hashtbl.add constmap id.xdr_name c
in
let resolve_const c =
match !c with
Constant (_,_) -> ()
| Named_constant n ->
( try
let sign,v = Hashtbl.find constmap n in
c := Constant(sign,v)
with
Not_found ->
error("Unknown constant `" ^ n ^ "'")
)
in
let rec check_type t = (
match t with
T_opaque_fixed c -> resolve_const c
| T_opaque c -> resolve_const c
| T_string c -> resolve_const c
| T_mstring(_,c) -> resolve_const c
| T_option t' -> check_type t'
| T_array_fixed(c,t') -> resolve_const c; check_type t'
| T_array(c,t') -> resolve_const c; check_type t'
| T_array_unlimited t'-> check_type t'
| T_enum l -> List.iter
(fun (id,c) ->
resolve_const c;
def_constant id (constant !c);
) l
| T_struct(_,td) -> List.iter check_type_decl td
| T_union u -> check_type_decl (u.discriminant);
List.iter (fun (c,_,td) ->
resolve_const c;
check_type_decl td) u.cases;
(match u.default with
Some td -> check_type_decl td
| None -> ()
)
| _ -> ()
)
and check_type_decl td =
try
check_type td.decl_type
with
Error s ->
error
("In the definition for `" ^ td.decl_symbol.xdr_name ^ "':\n" ^ s)
in
let rec check_progdef p =
try
List.iter check_versiondef p.prog_def
with
Error s ->
error
("In the definition for `" ^ p.prog_symbol.xdr_name ^ "':\n" ^ s)
and check_versiondef v =
try
List.iter check_procdef v.version_def
with
Error s ->
error
("In the definition for `" ^ v.version_symbol.xdr_name ^ "':\n" ^ s)
and check_procdef p =
try
List.iter check_type p.proc_params;
check_type p.proc_result
with
Error s ->
error
("In the definition for `" ^ p.proc_symbol.xdr_name ^ "':\n" ^ s)
in
List.iter
(function
Typedef td -> check_type_decl td
| Constdef (id, c) -> def_constant id c
| Progdef p -> check_progdef p
)
dl
;;
(**********************************************************************)
type env = (string, xdr_type) Hashtbl.t
;;
let check_type_constraints dl =
(* Checks that types are well-formed. Especially:
* - If types are referred to by name, it is checked whether the name
* is defined (forward references are accepted)
* - It is checked that types have unique names
* - It is checked that components of structs and unions have unique
* names
* - Size arguments of strings, arrays and opaque types must not be
* negative
* - It is checked whether discriminants of unions have integer or
* enumerator type
*)
let typemap = (Hashtbl.create 100 : env) in
let uniqueness_in_tdlist l =
let rec check names l =
match l with
x :: l' ->
let n = x.decl_symbol.xdr_name in
if n <> "" && List.mem n names then
error("Component `" ^ n ^ "' is defined twice");
(* n = "": used for void components *)
check (n::names) l'
| [] ->
()
in
check [] l
in
let unsigned_int (sign,v) =
if sign then
error("The numerical argument must be unsigned");
()
in
let signed_int (sign,v) =
let (c1,c2,c3,c4) = dest_uint4 v in
if sign then
( if c1 > '\128' ||
(c1 = '\128' && (c2 > '\000' || c3 > '\000' || c4 > '\000')) then
error "The numerical argument is too small"
)
else
if c1 >= '\128' then
error "The numerical argument is too big";
()
in
let convertible_to_int (sign,v) =
(* Only relevant on 32 bit systems *)
try ignore(int_of_uint4 v)
with _ ->
error "The numerical argument is not representable as int"
in
let rec get_type t =
match t with
T_refer_to (r,n) ->
let t' =
( try get_type(Hashtbl.find typemap !n)
with
Not_found ->
error ("Type `" ^ !n ^ "' is unknown")
)
in
(match r with
R_any -> ()
| R_struct ->
(match t' with
T_struct _ -> ()
| _ ->
error("Reference `struct " ^ !n ^ "' does not refer to struct"))
| R_union ->
(match t' with
T_union _ -> ()
| _ ->
error("Reference `union " ^ !n ^ "' does not refer to union"))
| R_enum ->
(match t' with
T_enum _ -> ()
| _ ->
error("Reference `enum " ^ !n ^ "' does not refer to enum"))
);
t'
| t -> t
in
let rec check_type t = (
match t with
T_opaque_fixed c -> unsigned_int (constant !c);
convertible_to_int (constant !c)
| T_opaque c -> unsigned_int (constant !c)
| T_string c -> unsigned_int (constant !c)
| T_mstring(_,c) -> unsigned_int (constant !c)
| T_option t' -> check_type t'
| T_array_fixed(c,t') -> unsigned_int (constant !c);
convertible_to_int (constant !c);
check_type t'
| T_array(c,t') -> unsigned_int (constant !c); check_type t'
| T_array_unlimited t' -> check_type t'
| T_refer_to n -> ignore(get_type t)
| T_enum l -> List.iter
(fun(_,c) -> signed_int (constant !c)) l
| T_struct(_,td) -> uniqueness_in_tdlist td;
List.iter check_type_decl td
| T_union u -> let defdecl =
match u.default with
None -> []
| Some td -> [td]
in
let casesdecls =
List.map (fun (_,_,td) -> td) u.cases in
let alldecls =
([u.discriminant] @ casesdecls @ defdecl) in
(* Note: because union component
* identifiers are not used in the
* language mapping, it is not necessary
* to check their uniqueness:
*)
(* uniqueness_in_tdlist alldecls; *)
List.iter check_type_decl alldecls;
check_cases u
| _ -> ()
)
and check_cases u = (
match get_type u.discriminant.decl_type with
T_int _ ->
List.iter (fun (c,_,d) -> signed_int (constant !c)) u.cases
| T_uint _ ->
List.iter (fun (c,_,d) -> unsigned_int (constant !c)) u.cases
| T_bool ->
List.iter
(fun (c,_,d) ->
let (sign,absval) as n = constant !c in
unsigned_int n;
match string_of_uint4 absval with
"0" -> ()
| "1" -> ()
| s ->
error ("Boolean case must be 0 or 1, not " ^ s)
)
u.cases
| T_enum l ->
List.iter
(fun (c,_,d) ->
let n = constant !c in
signed_int n;
if not (List.exists
(fun (_,c') -> !c' = !c)
l)
then
error "Bad enumerator case"
)
u.cases
| _ ->
error("The discriminant of the union type is ill-typed")
)
and check_type_decl td =
try
check_type td.decl_type
with
Error s ->
error
("In the definition for `" ^ td.decl_symbol.xdr_name ^ "':\n" ^ s)
in
let rec check_progdef p =
try
List.iter check_versiondef p.prog_def
with
Error s ->
error
("In the definition for `" ^ p.prog_symbol.xdr_name ^ "':\n" ^ s)
and check_versiondef v =
try
List.iter check_procdef v.version_def
with
Error s ->
error
("In the definition for `" ^ v.version_symbol.xdr_name ^ "':\n" ^ s)
and check_procdef p =
try
List.iter check_type p.proc_params;
check_type p.proc_result
with
Error s ->
error
("In the definition for `" ^ p.proc_symbol.xdr_name ^ "':\n" ^ s)
in
(* Form typemap: *)
List.iter
(function
Typedef td ->
( let n = td.decl_symbol.xdr_name in
try
let _t = Hashtbl.find typemap n in
(* Ignore the second type definition in some cases... *)
( match td.decl_type with
T_refer_to (_,n') ->
if n <> !n' then
error ("Type `" ^ n ^ "' is defined twice")
| _ ->
error ("Type `" ^ n ^ "' is defined twice")
)
with
Not_found ->
Hashtbl.add typemap n td.decl_type
)
| _ -> ()
)
dl;
(* Now check types: *)
List.iter
(function
Typedef td -> check_type_decl td
| Constdef _ -> ()
| Progdef p -> check_progdef p
)
dl
;;
(**********************************************************************)
let check_program_definitions dl =
(* Checks that names and numbers of programs, versions and procedures
* are unique in program definitions
*)
let program_names = ref [] in
let program_numbers = ref [] in
let check_program p =
let version_names = ref [] in
let version_numbers = ref [] in
let check_version v =
let proc_names = ref [] in
let proc_numbers = ref [] in
let check_procedure q =
let name = q.proc_symbol.xdr_name in
let number = q.proc_number in
if List.mem name !proc_names then
error("Procedure `" ^ name ^ "' is defined twice");
if List.mem number !proc_numbers then
error("Procedure number " ^ string_of_uint4 number ^ " is defined twice");
proc_names := name :: !proc_names;
proc_numbers := number :: !proc_numbers;
in
let name = v.version_symbol.xdr_name in
let number = v.version_number in
if List.mem name !version_names then
error("Version `" ^ name ^ "' is defined twice");
if List.mem number !version_numbers then
error("Version number " ^ string_of_uint4 number ^ " is defined twice");
version_names := name :: !version_names;
version_numbers := number :: !version_numbers;
List.iter check_procedure v.version_def
in
let name = p.prog_symbol.xdr_name in
let number = p.prog_number in
if List.mem name !program_names then
error("Program `" ^ name ^ "' is defined twice");
if List.mem number !program_numbers then
error("Program number " ^ string_of_uint4 number ^ " is defined twice");
program_names := name :: !program_names;
program_numbers := number :: !program_numbers;
List.iter check_version p.prog_def
in
List.iter
(function
Progdef p -> check_program p
| _ -> ()
)
dl
;;
