+++ /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 ()