(List.rev vlist), env
end
+module Pragma = struct
+ exception Missing_prefix of string * string
+
+ let is_space c = c = ' ' || c = '\t' || c = '\n'
+
+ let rev_strip_leading clist =
+ let do_char (l, pass) c =
+ if pass then c::l, true
+ else if is_space c then l, false
+ else c::l, true
+ in
+ fst (List.fold_left do_char ([], false) clist)
+
+ let trim clist =
+ rev_strip_leading (rev_strip_leading clist)
+
+ let clist_to_str clist =
+ let len = List.length clist in
+ let s = String.create len in
+ ignore (List.fold_left (fun pos c -> s.[pos] <- c; (pos - 1)) (len-1) clist);
+ s
+
+ let is_prefix prefix str =
+ let plen, slen = String.length prefix, String.length str in
+ (plen <= slen) && (String.sub str 0 plen = prefix)
+
+ let strip_prefix prefix str =
+ let plen, slen = String.length prefix, String.length str in
+ if is_prefix prefix str
+ then String.sub str plen (slen - plen)
+ else str
+
+ let record_prefix = ref ""
+ let process_pragma p =
+ let p = clist_to_str (trim p) in
+ (* Printf.printf "Saw pragma %s\n" p; *)
+ if is_prefix "set_record_prefix=" p then begin
+ record_prefix := strip_prefix "set_record_prefix=" p;
+ (* Printf.printf "Set record prefix to \"%s\"\n" !record_prefix *)
+ end else if is_prefix "clear_record_prefix" p then begin
+ record_prefix := "";
+ (* Printf.printf "Cleared record prefix\n" *)
+ end
+
+ let cook_To_field_name fn =
+ if is_prefix !record_prefix fn
+ then strip_prefix !record_prefix fn
+ else raise (Missing_prefix (!record_prefix, fn))
+
+ let cook_Of_field_name fn =
+ !record_prefix ^ fn
+end
+
type rec_type = First | Next
module To = struct
generate_from_def ff First h;
List.iter (generate_from_def ff Next) t
+let print_exception e =
+ match e with
+ | Unknown_base_type id ->
+ Printf.sprintf "Unknown base type \"%s\"" id
+ | Pragma.Missing_prefix (p, f) ->
+ Printf.sprintf "Prefix \"%s\" cannot be stripped from field \"%s\"" p f
+ | e ->
+ Printf.sprintf "%s" (Printexc.to_string e)
+
let generate defn_list ofn ifn =
reset_known_types ();
(try Unix.unlink ofn with _ -> ());
let ff = formatter_of_out_channel oc in
try
generate_header ff ifn;
- List.iter (generate_one_defn ff) defn_list;
+ List.iter (function
+ | Pragma p ->
+ Pragma.process_pragma p
+ | Type_defn def ->
+ generate_one_defn ff def
+ ) defn_list;
close_out oc
- with Unknown_base_type id ->
- Printf.eprintf "Error: Unknown base type \"%s\"\n" id;
+ with e ->
+ Printf.eprintf "Error: %s\n" (print_exception e);
close_out oc;
Unix.unlink ofn
let raise_syntax_error e loc =
raise (Syntax_error (e, loc))
+let cur_pragma = ref ([] : char list)
+
+let get_pragma () =
+ let p = !cur_pragma in
+ cur_pragma := [];
+ p
}
let letter = ['A'-'Z' 'a'-'z']
| "*)" { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
+| "(*** json-pragma: "
+ { pragma lexbuf; PRAGMA (get_pragma ()) }
+
| "(*" { comment_depth := 1; comment_start := lexeme_start_p lexbuf;
comment lexbuf; main lexbuf }
| ['\n'] { new_line lexbuf; comment lexbuf }
| eof { raise_syntax_error Unterminated_comment !comment_start }
| _ { comment lexbuf }
+
+and pragma = parse
+| " ***)" { (* done *) }
+| _ { cur_pragma := (lexeme_char lexbuf 0) :: !cur_pragma; pragma lexbuf }
%token EOF
%token <string> UIDENT LIDENT
+%token <char list> PRAGMA
%start defn_list
-%type <Syntax.type_defn list> defn_list
+%type <Syntax.defn list> defn_list
%%
defns:
| defns top_defn_term { $2 :: $1 }
+| defns pragma { $2 :: $1 }
| /* epsilon */ { [] }
;
+pragma:
+| PRAGMA { Pragma $1 }
top_defn_term:
-| defn semi { $1 }
+| defn semi { Type_defn $1 }
defn:
| TYPE eqn { [ $2 ] }
type type_defn = (string * complex_type) list
+type defn =
+ | Type_defn of type_defn
+ | Pragma of char list
+
test_list simple_type_to_json simple_type_of_json ss
let check_record_type () =
- let rs = [ { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
+ let rs = [ { record_int = 32;
+ record_int64 = 32L;
+ record_bool = false;
+ record_string = "record";
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
+ record_int_list = [ 0; 1; 2; -6; 4; 5];
+ record_int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ record_bool_array = [| false; true; false; false; true |];
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ record_prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
} ] in
test_list record_type_to_json record_type_of_json rs
test_list complex_type1_to_json complex_type1_of_json cs
let check_complex_type2 () =
- let cs = [ { record = { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
+ let cs = [ { record = { record_int = 32;
+ record_int64 = 32L;
+ record_bool = false;
+ record_string = "record";
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
+ record_int_list = [ 0; 1; 2; -6; 4; 5];
+ record_int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ record_bool_array = [| false; true; false; false; true |];
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ record_prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
};
complex_type1 = [| ([4; 3; 1], false); ([1; 3; 4], true) |];
}
| S_int64_array of int64 array
| S_string_array of string array
+(*** json-pragma: set_record_prefix=record_ ***)
+
type record_type =
{
- int: int;
- int64: int64;
- bool: bool;
- string: string;
+ record_int: int;
+ record_int64: int64;
+ record_bool: bool;
+ record_string: string;
- int_list: int list;
- int64_option_array: (int64 option) array;
- bool_array: bool array;
+ record_int_list: int list;
+ record_int64_option_array: (int64 option) array;
+ record_bool_array: bool array;
- prod_list: ((int * bool) list) * string;
+ record_prod_list: ((int * bool) list) * string;
}
-
+
+(*** json-pragma: clear_record_prefix ***)
type complex_type1 = ((int list) * bool) array
projects / xenclient / toolstack.git / commitdiff