helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/varcc.ml

   1 (* $Id$ *)
   2
   3 (* Compile a list of variant tags into CPP defines *)
   4
   5 (* hash_variant, from ctype.ml *)
   6
   7 let hash_variant s =
   8   let accu = ref 0 in
   9   for i = 0 to String.length s - 1 do
  10     accu := 223 * !accu + Char.code s.[i]
  11   done;
  12   (* reduce to 31 bits *)
  13   accu := !accu land (1 lsl 31 - 1);
  14   (* make it signed for 64 bits architectures *)
  15   if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
  16
  17 open Genlex
  18
  19 let lexer = make_lexer ["type"; "public"; "="; "["; "]"; "`"; "|"]
  20
  21 let may_string = parser
  22     [< ' String s >] -> s
  23   | [< >] -> ""
  24
  25 let may_bar = parser
  26     [< ' Kwd "|" >] -> ()
  27   | [< >] -> ()
  28
  29 let rec ident_list = parser
  30     [< ' Kwd "`"; ' Ident x; trans = may_string; _ = may_bar; s >] ->
  31       (x, trans) :: ident_list s
  32   | [< >] -> []
  33
  34 let static = ref false
  35 let may_public = parser
  36     [< ' Kwd "public" >] -> true
  37   | [< ' Kwd "private" >] -> false
  38   | [< >] -> not !static
  39
  40 open Printf
  41
  42 let hashes = Hashtbl.create 57
  43
  44 let declaration ~hc ~cc = parser
  45     [< ' Kwd "type"; public = may_public; ' Ident name; ' Kwd "=";
  46        prefix = may_string; ' Kwd "["; _ = may_bar;
  47        tags = ident_list; ' Kwd "]"; suffix = may_string >] ->
  48     let oh x = fprintf hc x and oc x = fprintf cc x in
  49     (* Output tag values to headers *)
  50     let first = ref true in
  51     List.iter tags ~f:
  52       begin fun (tag, _) ->
  53         let hash = hash_variant tag in
  54         try
  55           let tag' = Hashtbl.find hashes hash in
  56           if tag <> tag' then
  57             failwith (String.concat ~sep:" " ["Doublon tag:";tag;"and";tag'])
  58         with Not_found ->
  59           Hashtbl.add ~key:hash ~data:tag hashes;
  60           if !first then begin
  61             oh "/* %s : tags and macros */\n" name; first := false
  62           end;
  63           oh "#define MLTAG_%s\tVal_int(%d)\n" tag hash;
  64       end;
  65     (* compute C name *)
  66     let ctag tag trans =
  67       if trans <> "" then trans else
  68       let tag =
  69         if tag.[0] = '_' then
  70           String.sub tag ~pos:1 ~len:(String.length tag -1)
  71         else tag
  72       in
  73       match
  74         if prefix = "" then None, ""
  75         else
  76           Some (prefix.[String.length prefix - 1]),
  77           String.sub prefix ~pos:0 ~len:(String.length prefix - 1)
  78       with
  79         Some '#', prefix ->
  80           prefix ^ String.uncapitalize tag ^ suffix
  81       | Some '^', prefix ->
  82           prefix ^ String.uppercase tag ^ suffix
  83       | _ ->
  84           prefix ^ tag ^ suffix
  85     and cname =
  86       String.capitalize name
  87     in
  88     let tags =
  89       Sort.list tags
  90         ~order:(fun (tag1,_) (tag2,_) -> hash_variant tag1 < hash_variant tag2)
  91     in
  92     (* Output table to code file *)
  93     oc "/* %s : conversion table */\n" name;
  94     let static = if not public then "static " else "" in
  95     oc "%slookup_info ml_table_%s[] = {\n" static name;
  96     oc "  { 0, %d },\n" (List.length tags);
  97     List.iter tags ~f:
  98       begin fun (tag,trans) ->
  99         oc "  { MLTAG_%s, %s },\n" tag (ctag tag trans)
 100       end;
 101     oc "};\n\n";
 102     (* Output macros to headers *)
 103     if not !first then oh "\n";
 104     if public then oh "extern lookup_info ml_table_%s[];\n" name;
 105     oh "#define Val_%s(data) ml_lookup_from_c (ml_table_%s, data)\n"
 106       name name;
 107     oh "#define %s_val(key) ml_lookup_to_c (ml_table_%s, key)\n\n"
 108       cname name;
 109   | [< >] -> raise End_of_file
 110
 111
 112 let process ic ~hc ~cc =
 113   let chars = Stream.of_channel ic in
 114   let s = lexer chars in
 115   try
 116     while true do declaration s ~hc ~cc done
 117   with End_of_file -> ()
 118   | Stream.Error err ->
 119       failwith
 120         (Printf.sprintf "Parsing error \"%s\" at character %d on input stream"
 121            err (Stream.count chars))
 122
 123 let main () =
 124   let inputs = ref [] in
 125   let header = ref "" in
 126   let code = ref "" in
 127   Arg.parse ~errmsg:"usage: varcc [options] file.var" ~keywords:
 128     [ "-h", Arg.String ((:=) header), "file to output macros (file.h)";
 129       "-c", Arg.String ((:=) code),
 130       "file to output conversion tables (file.c)";
 131       "-static", Arg.Set static, "do not export conversion tables" ]
 132     ~others:(fun s -> inputs := s :: !inputs);
 133   let inputs = List.rev !inputs in
 134   begin match inputs with
 135   | [] ->
 136       if !header = "" then header := "a.h";
 137       if !code = "" then code := "a.c"
 138   | ip :: _ ->
 139       let rad =
 140         if Filename.check_suffix ip ".var" then Filename.chop_extension ip
 141         else ip in
 142       if !header = "" then header := rad ^ ".h";
 143       if !code = "" then code := rad ^ ".c"
 144   end;
 145   let hc = open_out !header and cc = open_out !code in
 146   let chars = Stream.of_channel stdin in
 147   if inputs = [] then process stdin ~hc ~cc else begin
 148     List.iter inputs ~f:
 149       begin fun file ->
 150         let ic = open_in file in
 151         try process ic ~hc ~cc; close_in ic
 152         with exn -> close_in ic; prerr_endline ("Error in " ^ file); raise exn
 153       end
 154   end;
 155   close_out hc; close_out cc
 156
 157 let _ = Printexc.print main ()