--- /dev/null
+(* $Id$ *)
+
+(* Compile a list of variant tags into CPP defines *)
+
+(* hash_variant, from ctype.ml *)
+
+let hash_variant s =
+ let accu = ref 0 in
+ for i = 0 to String.length s - 1 do
+ accu := 223 * !accu + Char.code s.[i]
+ done;
+ (* reduce to 31 bits *)
+ accu := !accu land (1 lsl 31 - 1);
+ (* make it signed for 64 bits architectures *)
+ if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+open Genlex
+
+let lexer = make_lexer ["type"; "public"; "="; "["; "]"; "`"; "|"]
+
+let may_string = parser
+ [< ' String s >] -> s
+ | [< >] -> ""
+
+let may_bar = parser
+ [< ' Kwd "|" >] -> ()
+ | [< >] -> ()
+
+let rec ident_list = parser
+ [< ' Kwd "`"; ' Ident x; trans = may_string; _ = may_bar; s >] ->
+ (x, trans) :: ident_list s
+ | [< >] -> []
+
+let static = ref false
+let may_public = parser
+ [< ' Kwd "public" >] -> true
+ | [< ' Kwd "private" >] -> false
+ | [< >] -> not !static
+
+open Printf
+
+let hashes = Hashtbl.create 57
+
+let declaration ~hc ~cc = parser
+ [< ' Kwd "type"; public = may_public; ' Ident name; ' Kwd "=";
+ prefix = may_string; ' Kwd "["; _ = may_bar;
+ tags = ident_list; ' Kwd "]"; suffix = may_string >] ->
+ let oh x = fprintf hc x and oc x = fprintf cc x in
+ (* Output tag values to headers *)
+ let first = ref true in
+ List.iter tags ~f:
+ begin fun (tag, _) ->
+ let hash = hash_variant tag in
+ try
+ let tag' = Hashtbl.find hashes hash in
+ if tag <> tag' then
+ failwith (String.concat ~sep:" " ["Doublon tag:";tag;"and";tag'])
+ with Not_found ->
+ Hashtbl.add ~key:hash ~data:tag hashes;
+ if !first then begin
+ oh "/* %s : tags and macros */\n" name; first := false
+ end;
+ oh "#define MLTAG_%s\tVal_int(%d)\n" tag hash;
+ end;
+ (* compute C name *)
+ let ctag tag trans =
+ if trans <> "" then trans else
+ let tag =
+ if tag.[0] = '_' then
+ String.sub tag ~pos:1 ~len:(String.length tag -1)
+ else tag
+ in
+ match
+ if prefix = "" then None, ""
+ else
+ Some (prefix.[String.length prefix - 1]),
+ String.sub prefix ~pos:0 ~len:(String.length prefix - 1)
+ with
+ Some '#', prefix ->
+ prefix ^ String.uncapitalize tag ^ suffix
+ | Some '^', prefix ->
+ prefix ^ String.uppercase tag ^ suffix
+ | _ ->
+ prefix ^ tag ^ suffix
+ and cname =
+ String.capitalize name
+ in
+ let tags =
+ Sort.list tags
+ ~order:(fun (tag1,_) (tag2,_) -> hash_variant tag1 < hash_variant tag2)
+ in
+ (* Output table to code file *)
+ oc "/* %s : conversion table */\n" name;
+ let static = if not public then "static " else "" in
+ oc "%slookup_info ml_table_%s[] = {\n" static name;
+ oc " { 0, %d },\n" (List.length tags);
+ List.iter tags ~f:
+ begin fun (tag,trans) ->
+ oc " { MLTAG_%s, %s },\n" tag (ctag tag trans)
+ end;
+ oc "};\n\n";
+ (* Output macros to headers *)
+ if not !first then oh "\n";
+ if public then oh "extern lookup_info ml_table_%s[];\n" name;
+ oh "#define Val_%s(data) ml_lookup_from_c (ml_table_%s, data)\n"
+ name name;
+ oh "#define %s_val(key) ml_lookup_to_c (ml_table_%s, key)\n\n"
+ cname name;
+ | [< >] -> raise End_of_file
+
+
+let process ic ~hc ~cc =
+ let chars = Stream.of_channel ic in
+ let s = lexer chars in
+ try
+ while true do declaration s ~hc ~cc done
+ with End_of_file -> ()
+ | Stream.Error err ->
+ failwith
+ (Printf.sprintf "Parsing error \"%s\" at character %d on input stream"
+ err (Stream.count chars))
+
+let main () =
+ let inputs = ref [] in
+ let header = ref "" in
+ let code = ref "" in
+ Arg.parse ~errmsg:"usage: varcc [options] file.var" ~keywords:
+ [ "-h", Arg.String ((:=) header), "file to output macros (file.h)";
+ "-c", Arg.String ((:=) code),
+ "file to output conversion tables (file.c)";
+ "-static", Arg.Set static, "do not export conversion tables" ]
+ ~others:(fun s -> inputs := s :: !inputs);
+ let inputs = List.rev !inputs in
+ begin match inputs with
+ | [] ->
+ if !header = "" then header := "a.h";
+ if !code = "" then code := "a.c"
+ | ip :: _ ->
+ let rad =
+ if Filename.check_suffix ip ".var" then Filename.chop_extension ip
+ else ip in
+ if !header = "" then header := rad ^ ".h";
+ if !code = "" then code := rad ^ ".c"
+ end;
+ let hc = open_out !header and cc = open_out !code in
+ let chars = Stream.of_channel stdin in
+ if inputs = [] then process stdin ~hc ~cc else begin
+ List.iter inputs ~f:
+ begin fun file ->
+ let ic = open_in file in
+ try process ic ~hc ~cc; close_in ic
+ with exn -> close_in ic; prerr_endline ("Error in " ^ file); raise exn
+ end
+ end;
+ close_out hc; close_out cc
+
+let _ = Printexc.print main ()