helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/var2def.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 ["`"; "["; "]"; "|"]
  20
  21 let main () =
  22   let s = lexer (Stream.of_channel stdin) in
  23   let tags = Hashtbl.create 57 in
  24   while match s with parser
  25     [< ' Kwd "`"; ' Ident tag >] ->
  26       let hash = hash_variant tag in
  27       begin try
  28         let tag' = Hashtbl.find tags hash in
  29         if tag <> tag' then
  30           failwith (String.concat ~sep:" " ["Doublon tag:";tag;"and";tag'])
  31       with Not_found ->
  32         Hashtbl.add ~key:hash ~data:tag tags;
  33         print_string "#define MLTAG_";
  34         print_string tag;
  35         print_string "\tVal_int(";
  36         print_int hash;
  37         print_string ")\n"
  38       end;
  39       true
  40   | [< ' _ >] -> true
  41   | [< >] -> false
  42   do () done
  43
  44 let _ = Printexc.print main ()