]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/varcc.ml
.cvsignore files missing
[helm.git] / 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 ()