helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/var2conv.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"; "exception"; "="; "["; "]"; "`"; "|"]
  20
  21 let exn_name = ref "invalid_argument"
  22
  23 let may_string = parser
  24     [< ' String s >] -> s
  25   | [< >] -> ""
  26
  27 let may_bar = parser
  28     [< ' Kwd "|" >] -> ()
  29   | [< >] -> ()
  30
  31 let rec ident_list = parser
  32     [< ' Kwd "`"; ' Ident x; trans = may_string; _ = may_bar; s >] ->
  33       (x, trans) :: ident_list s
  34   | [< >] -> []
  35
  36 let may_public = parser
  37     [< ' Kwd "public" >] -> true
  38   | [< >] -> false
  39
  40 open Printf
  41
  42 let declaration = parser
  43     [< ' Kwd "type"; public = may_public; ' Ident name; ' Kwd "=";
  44        prefix = may_string; ' Kwd "["; _ = may_bar;
  45        tags = ident_list; ' Kwd "]"; suffix = may_string >] ->
  46     let ctag tag trans =
  47       if trans <> "" then trans else
  48       let tag =
  49         if tag.[0] = '_' then
  50           String.sub tag ~pos:1 ~len:(String.length tag -1)
  51         else tag
  52       in
  53       match
  54         if prefix = "" then None, ""
  55         else
  56           Some (prefix.[String.length prefix - 1]),
  57           String.sub prefix ~pos:0 ~len:(String.length prefix - 1)
  58       with
  59         Some '#', prefix ->
  60           prefix ^ String.uncapitalize tag ^ suffix
  61       | Some '^', prefix ->
  62           prefix ^ String.uppercase tag ^ suffix
  63       | _ ->
  64           prefix ^ tag ^ suffix
  65     and cname =
  66       String.capitalize name
  67     in
  68     let tags =
  69       Sort.list tags
  70         ~order:(fun (tag1,_) (tag2,_) -> hash_variant tag1 < hash_variant tag2)
  71     in
  72     printf "/* %s : conversion table */\n" name;
  73     if not public then printf "static ";
  74     printf "lookup_info ml_table_%s[] = {\n" name;
  75     printf "  { 0, %d },\n" (List.length tags);
  76     List.iter tags ~f:
  77       begin fun (tag,trans) ->
  78         printf "  { MLTAG_%s, %s },\n" tag (ctag tag trans)
  79       end;
  80     printf "};\n\n";
  81     printf "#define Val_%s(data) ml_lookup_from_c (ml_table_%s, data)\n"
  82       name name;
  83     printf "#define %s_val(key) ml_lookup_to_c (ml_table_%s, key)\n\n"
  84       cname name;
  85   | [< 'Kwd"exception"; 'Ident name >] ->
  86       exn_name := name
  87   | [< >] -> raise End_of_file
  88
  89 let main () =
  90   let chars = Stream.of_channel stdin in
  91   let s = lexer chars in
  92   try
  93     while true do declaration s done
  94   with End_of_file -> ()
  95   | Stream.Error err ->
  96       Printf.eprintf "Parsing error \"%s\" at character %d on input stream"
  97         err (Stream.count chars)
  98
  99 let _ = Printexc.print main ()