57e825895b6d07158aa9c61b6190ec68aceac110
[apps/madmutt.git] / tools / cpkg2c.mll
1 (*
2  *  This program is free software; you can redistribute it and/or modify
3  *  it under the terms of the GNU General Public License as published by
4  *  the Free Software Foundation; either version 2 of the License, or (at
5  *  your option) any later version.
6  *
7  *  This program is distributed in the hope that it will be useful, but
8  *  WITHOUT ANY WARRANTY; without even the implied warranty of
9  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
10  *  General Public License for more details.
11  *
12  *  You should have received a copy of the GNU General Public License
13  *  along with this program; if not, write to the Free Software
14  *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
15  *  MA 02110-1301, USA.
16  *
17  *  Copyright © 2007 Pierre Habouzit
18  *)
19 {
20   open Printf
21   module L = Lexing
22   module H = Hashtbl
23   module B = Buffer
24
25   type 'a anchor   = ('a * string * int)
26   let t1 (a, _, _) = a
27
28   let die lpos fpos s =
29     output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
30     exit 1
31
32   let put_line = printf "#line %d \"%s\"\n"
33
34   let isspace = function |' '|'\t' -> true | _ -> false
35
36   let strip s =
37     let l = ref 0 and r = ref (String.length s) in
38     while (isspace s.[!l]     && !l < !r) do incr l done;
39     while (isspace s.[!r - 1] && !l < !r) do decr r done;
40     String.sub s !l (!r - !l)
41
42 (* @types related {{{ *)
43
44   type typedef =
45     { lpos: int; fpos: string;
46       ctype: string anchor;
47       check: string anchor;
48       push : string anchor;
49       ctor : string anchor option;
50       dtor : string anchor option;
51     }
52   let typedef0 =
53     { lpos  = 0; fpos = "";
54       ctype = ("", "", 0);
55       check = ("", "", 0);
56       push  = ("", "", 0);
57       ctor  = None;
58       dtor = None
59     }
60   let types = H.create 1031
61
62
63   let (@:=) id  t =
64     List.iter (function ((s,_,_), x) -> if String.length s == 0 then
65       die t.lpos t.fpos (sprintf "type `%s' has no `%s' set" id x))
66     [(t.ctype, "ctype"); (t.check, "check"); (t.push, "push")];
67     H.add types id t
68
69 (* }}} *)
70 (* @packages related {{{ *)
71
72   type typinst = bool * typedef
73
74   type members =
75     { typ: typinst; mname: string; init: string }
76
77   type methods =
78     { rettype: typinst list; args: (typinst * string) list;
79       fname: string; body: string }
80
81   type package =
82     { line: int; file: string; name: string;
83       members: members anchor list;
84       methods: methods anchor list;
85       static: bool;
86     }
87
88   let newpkg lpos fpos name static =
89     { static = static; line = lpos; file = fpos; name = name; members = []; methods = []; }
90
91   let type_find lpos fpos t =
92     try Hashtbl.find types t
93     with Not_found -> die lpos fpos (sprintf "Unknown type `%s'" t)
94
95   let parse_rettype lpos fpos s =
96     let aux t =
97       match Str.split (Str.regexp "[ \t]+") t with
98       | ["const"; t] -> (true,  type_find lpos fpos t)
99       | [t]          -> (false, type_find lpos fpos t)
100       | _ -> assert false
101     in
102     match strip s with
103     | "void" -> []
104     | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
105
106   let parse_args lpos fpos s =
107     let aux t =
108       match Str.split (Str.regexp "[ \t]+") t with
109       | ["const"; t; n] -> ((true,  type_find lpos fpos t), n)
110       | [t; n]          -> ((false, type_find lpos fpos t), n)
111       | _ -> assert false
112     in
113     match strip s with
114     | "void" -> []
115     | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
116
117 (* }}} *)
118 (* parsing helpers {{{ *)
119
120   type stanza = Buf of string anchor | Pkg of package
121
122   let nextl lexbuf =
123     let pos = lexbuf.L.lex_curr_p in
124     lexbuf.L.lex_curr_p <-
125       { pos with
126         L.pos_lnum = pos.L.pos_lnum + 1;
127         L.pos_bol  = pos.L.pos_cnum; };
128     lexbuf
129   ;;
130
131   let lnum lexbuf = lexbuf.L.lex_curr_p.L.pos_lnum
132
133   let (@.)  buf s = B.add_string buf s; buf
134   let (@<)  buf c = B.add_char   buf c; buf
135
136   let getchunk lpos fpos buf lexbuf =
137     let res = B.contents buf in
138     B.clear buf;
139     Buf(res, fpos, lpos)
140
141   let startchunk f fpos lexbuf =
142     f (lnum lexbuf) fpos (B.create 4096) lexbuf
143
144   let newchunk f lpos fpos buf lexbuf =
145     let res = getchunk lpos fpos buf lexbuf in
146     res::(f (lnum lexbuf, fpos) buf lexbuf)
147
148   let find_import relpath file =
149     if Filename.is_relative file then
150       match Filename.dirname relpath with
151       | "." -> file
152       | s   -> Filename.concat s file
153     else
154       file
155
156 (* }}} *)
157 }
158
159 (* regex aliases {{{ *)
160
161 let to_eol = [^'\n']* '\n'
162 let ident  = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''_''0'-'9']*
163 let sp     = [' ''\t']
164
165 let typdecl = sp* ("const" sp+)? ident sp*
166
167 (* }}} *)
168 (* entry point {{{ *)
169
170 rule cLine lpos fpos buf = parse
171 | sp* "@type" sp+ (ident as id) sp* (':' sp* (ident as id0) sp*)? '{'
172                     {
173                       let line = lnum lexbuf in
174                       let t0 = match id0 with
175                       | None     -> typedef0
176                       | Some id0 ->
177                           try H.find types id0
178                           with Not_found ->
179                             die line fpos (sprintf "Uknown type `%s'" id0)
180                       in try
181                         let t = H.find types id in
182                         die line fpos
183                           (sprintf "type `%s' already defined at %s:%d"
184                             id t.fpos t.lpos)
185                       with Not_found ->
186                         (getchunk lpos fpos buf lexbuf) :: (
187                           ext_type id {t0 with lpos = line; fpos = fpos}
188                             lexbuf
189                         )
190                     }
191 | sp* "@import" sp+ '"' ([^'"''\n']* as file) '"' sp* '\n'
192                     {
193                       let file = find_import fpos file in
194                       let _ = startchunk cLine file
195                                 (L.from_channel (open_in file)) in
196                       cLine lpos fpos (buf @< '\n') (nextl lexbuf)
197                     }
198 | sp* ("@package"|"@static_package" as kw) sp+ (ident as pkg) sp* '{'
199                     {
200                       let a = getchunk lpos fpos buf lexbuf in
201                       let line = lnum lexbuf in
202                       a::(ext_pkg (newpkg line fpos pkg
203                                     (kw = "@static_package")) lexbuf)
204                     }
205 | sp* '@'           { die (lnum lexbuf) fpos "Syntax error" }
206 | sp* '#' as s      { let buf = cPP (buf @. s) lexbuf in
207                       cLine lpos fpos buf lexbuf }
208 | ""                { let buf = cCode buf lexbuf in
209                       cLine lpos fpos buf lexbuf }
210 | eof               { [getchunk lpos fpos buf lexbuf] }
211
212 (* }}} *)
213 (* cCode block parser {{{ *)
214
215 and cCode buf = parse
216 | '\n'    as c      { let _ = nextl lexbuf in buf @< c }
217 | '"'     as c      { let buf = cString (buf @< c) lexbuf in
218                       cCode buf lexbuf }
219 | "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
220                       cCode buf lexbuf }
221 | "//" to_eol as s  { cCode (buf @. s) (nextl lexbuf) }
222 | "'\"'"  as s      { cCode (buf @. s) lexbuf }
223 | _       as c      { cCode (buf @< c) lexbuf }
224
225 (* }}} *)
226 (* helper rules: comment, string, cPP {{{ *)
227
228 and cComment buf = parse
229 | "*/"    as s { buf @. s }
230 | '\n'    as c { cComment (buf @< c) (nextl lexbuf) }
231 | _       as c { cComment (buf @< c) lexbuf }
232
233 and cString buf = parse
234 | '"'     as c { buf @< c }
235 | "\\\""  as s { cString (buf @. s) lexbuf }
236 | "\\\n"  as s { cString (buf @. s) (nextl lexbuf) }
237 | [^'\n'] as c { cString (buf @< c) lexbuf }
238
239 and cPP buf = parse
240 | [^'\n']* "\\\n" as s { cPP (buf @. s) (nextl lexbuf) }
241 | to_eol          as s { let _ = nextl lexbuf in buf @. s }
242
243 (* }}} *)
244 (* parse @type {{{ *)
245
246 and ext_type id typ = parse
247 | sp+
248 | "//" to_eol       { ext_type id typ lexbuf }
249 | '\n'              { ext_type id typ (nextl lexbuf) }
250 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
251                       ext_type id typ lexbuf }
252 | '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
253                     {
254                       ext_type id (
255                         let do_anch s = s, typ.fpos, lnum lexbuf in
256                         match member with
257                         | "ctype" -> {typ with ctype = do_anch s}
258                         | "check" -> {typ with check = do_anch s}
259                         | "push"  -> {typ with push  = do_anch s}
260                         | "ctor"  -> {typ with ctor  = Some (do_anch s)}
261                         | "dtor"  -> {typ with dtor  = Some (do_anch s)}
262                         | _       ->
263                             die (lnum lexbuf) typ.fpos
264                               (sprintf "Unknown directive `%s'" member)
265                       ) lexbuf
266                     }
267 | '}' sp* ';' (sp* '\n' as s)?
268                     { id @:= typ; startchunk cLine typ.fpos
269                       (if s = None then lexbuf else nextl lexbuf) }
270 | ""                { die (lnum lexbuf) typ.fpos "Syntax error" }
271
272 (* }}} *)
273 (* parse @package {{{ *)
274
275 and ext_pkg pkg = parse
276 | sp+
277 | "//" to_eol       { ext_pkg pkg lexbuf }
278 | '\n'              { ext_pkg pkg (nextl lexbuf) }
279 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
280                       ext_pkg pkg lexbuf }
281 | ("const" sp+ as const)? (ident as typ) sp+
282   (ident as member) sp* '=' sp* ([^';''\n']* as init)';'
283                     {
284                       let m = { typ   = const != None,
285                                         type_find (lnum lexbuf) pkg.file typ;
286                                 mname = member;
287                                 init  = init; }, pkg.file, lnum lexbuf in
288                       ext_pkg {pkg with members = m::pkg.members} lexbuf
289                     }
290 | '(' ((typdecl ',')* typdecl as ret) ')' sp*
291    (ident as fname)
292    '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
293 | (typdecl as ret) (ident as fname)
294    '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
295                     {
296                       let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
297                       let args    = parse_args    (lnum lexbuf) pkg.file args in
298                       let body    = ext_body pkg (B.create 1024) lexbuf in
299                       let m       = { rettype = rettype;
300                                       args = args;
301                                       fname = fname;
302                                       body = body }, pkg.file, lnum lexbuf in
303                       ext_pkg {pkg with methods = m::pkg.methods} lexbuf
304                     }
305 | '}' sp* ';' (sp* '\n' as s)?
306                     { Pkg({pkg with members = List.rev(pkg.members)}) :: (
307                         startchunk cLine pkg.file
308                         (if s = None then lexbuf else nextl lexbuf)
309                       )
310                     }
311 | ""                { die (lnum lexbuf) pkg.file "Syntax error" }
312
313 and ext_body pkg buf = parse
314 | sp+         as s
315 | "//" to_eol as s  { ext_body pkg (buf @. s) lexbuf }
316 | '\n'        as c  { ext_body pkg (buf @< c) lexbuf }
317 | "/*"              { let buf = cComment (buf @. "/*") lexbuf in
318                       ext_body pkg buf lexbuf }
319 | ';'               { B.contents buf }
320 | '{'         as c  { let buf = ext_bodycode (buf @< c) lexbuf in
321                       ext_body pkg buf lexbuf }
322 | ""                { die (lnum lexbuf) pkg.file "Syntax error" }
323
324 and ext_bodycode buf = parse
325 | '\n'    as c      { ext_bodycode (buf @< c) (nextl lexbuf) }
326 | '"'     as c      { let buf = cString (buf @< c) lexbuf in
327                       ext_bodycode buf lexbuf }
328 | "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
329                       ext_bodycode buf lexbuf }
330 | "//" to_eol as s  { ext_bodycode (buf @. s) (nextl lexbuf) }
331 | "'\"'"  as s      { ext_bodycode (buf @. s) lexbuf }
332 | '{'     as c      { let buf = ext_bodycode (buf @< c) lexbuf in ext_bodycode buf lexbuf }
333 | '}'     as c      { buf @< c }
334 | _       as c      { ext_bodycode (buf @< c) lexbuf }
335
336 (* }}} *)
337
338 {
339 (* templating functions {{{ *)
340
341   let upper = String.uppercase
342   let tplize tpl v =
343     Str.global_replace (Str.regexp_string "$L") "L" (
344       Str.global_replace (Str.regexp_string "$$") v tpl
345     )
346
347   let dump_struct_type begwith pkg endwith =
348     printf "%sstruct luaM_%s_t {\n" begwith pkg.name;
349     List.iter (function (m, f, l) ->
350       put_line l f;
351       let ctype = t1 (snd m.typ).ctype in
352       print_string "    ";
353       if fst m.typ then print_string "const ";
354       let i = try String.index ctype ':' with Not_found -> String.length ctype in
355       printf "%s %s%s;\n" (Str.string_before ctype i)
356         m.mname (Str.string_after ctype i)
357     ) pkg.members;
358     print_endline ("}" ^ endwith)
359
360   let do_h =
361     let do_h_aux = function
362       | Buf _ -> ()
363       | Pkg pkg ->
364           printf "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
365           printf "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);
366           if not pkg.static then (
367             dump_struct_type "" pkg ";";
368             printf "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;
369           );
370           printf "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
371           printf "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
372     in List.iter do_h_aux
373
374   let do_func pkg (fn, f, l) = 
375     (* return inline function *)
376     printf "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;
377     let retlen = List.fold_left (fun i t ->
378       let i = i + 1 in
379       match t with
380       | true, typ -> printf ", const %s luaM_x%d" (t1 typ.ctype) i; i
381       | false, typ -> printf ", %s luaM_x%d" (t1 typ.ctype) i; i
382       ) 0 fn.rettype in
383     printf ")\n{\n";
384     ignore (List.fold_left (fun i (const, typ) ->
385       let i = i + 1 in
386       let (p, f, l) = typ.push in
387       put_line l f;
388       printf "    %s;\n" (tplize p (sprintf "luaM_x%d" i));
389       if not const then (
390         match typ.dtor with
391         | None             -> ()
392         | Some(dtor, f, l) ->
393             put_line l f;
394             printf "    %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))
395       ); i
396     ) 0 fn.rettype) ;
397     printf "    return %d;\n}\n" retlen;
398
399     (* main function *)
400     printf "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
401     ignore (List.fold_left (fun i ((const, typ), name) ->
402       let i = i + 1 in
403       let ctype = t1 typ.ctype in
404       if const then (
405         let (c, f, l) = typ.check in
406         put_line l f;
407         printf "    const %s %s = %s;\n" ctype name (tplize c (string_of_int i))
408       ) else (
409         match typ.ctor with
410         | None ->
411           let (c, f, l) = typ.check in
412           put_line l f;
413           printf "    %s %s = %s;\n" ctype name (tplize c (string_of_int i))
414         | Some (ctor, f, l) ->
415           let v =
416             let c, f, l = typ.check in
417             tplize (sprintf "\n#line %d \"%s\"\n        %s" l f c)
418               (string_of_int i)
419           in
420           put_line l f;
421           printf "    %s %s = %s;\n" ctype name (tplize ctor v)
422       ); i
423     ) 0 fn.args);
424     printf "\n#define RAISE(s)  luaL_error(L, (s))\n";
425     if fn.rettype = [] then (
426       printf "#define RETURN()  return luaM_ret_%s_%s(L)\n" pkg.name fn.fname
427     ) else (
428       printf "#define RETURN(luaM_x1";
429       for i = 2 to retlen do printf ", luaM_x%d" i done;
430       printf ") \\\n        return luaM_ret_%s_%s(L" pkg.name fn.fname;
431       for i = 1 to retlen do printf ", luaM_x%d" i done;
432       printf ")\n"
433     );
434     put_line l f;
435     printf "    %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body
436
437   let do_c =
438     let do_c_aux = function
439       | Buf (s, f, l) -> put_line l f; print_string s
440       | Pkg pkg       ->
441           (* dump struct const init *)
442           (if pkg.static then
443             dump_struct_type "static " pkg (sprintf " %s = {\n" pkg.name)
444           else
445             printf "struct luaM_%s_t %s = {\n" pkg.name pkg.name
446           );
447           List.iter (function (m, f, l) ->
448               put_line l f;
449               printf "    %s,\n" (if fst m.typ then m.init else "0")
450             ) pkg.members;
451           printf "};\n";
452
453           (* dump struct init func *)
454           printf "\nstatic void %s_init(void)\n{\n" pkg.name;
455           List.iter (function (m, f, l) ->
456             if not (fst m.typ) then
457               printf "#line %d \"%s\"\n    %s.%s = %s;\n"
458               l f pkg.name m.mname m.init) pkg.members;
459           printf "};\n\n";
460
461           (* dump __index *)
462           printf "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
463           printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
464           printf "    switch (mlua_which_token(idx, -1)) {\n";
465           printf "      default:\n";
466           List.iter (function (m, _, _) ->
467             printf "      case LTK_%s:\n" (upper m.mname);
468             let push, f, l = (snd m.typ).push in
469             put_line l f;
470             printf "        %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
471             printf "        return 1;\n"
472           ) pkg.members;
473           printf "        lua_rawget(L, lua_upvalueindex(2));\n";
474           printf "        return 1;\n";
475           printf "    }\n}\n\n";
476
477           (* dump __newindex *)
478           printf "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
479           printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
480           printf "    switch (mlua_which_token(idx, -1)) {\n";
481           List.iter (function (m, _, _) ->
482             match m.typ with
483             | true, _ -> ()
484             | false, t ->
485               printf "      case LTK_%s:\n" (upper m.mname);
486               (match t.dtor with
487               | None -> ()
488               | Some (dtor, f, l) ->
489                   put_line l f;
490                   printf "        %s;\n" (tplize dtor (sprintf "&%s.%s" pkg.name m.mname))
491               );
492               (match t.ctor with
493               | None ->
494                   let (c, f, l) = t.check in
495                   put_line l f;
496                   printf "        %s.%s = %s;\n" pkg.name m.mname (tplize c "3")
497               | Some (ctor, f, l) ->
498                   let v =
499                     let c, f, l = t.check in
500                     tplize (sprintf "\n#line %d \"%s\"\n            %s" l f c) "3"
501                   in
502                   put_line l f;
503                   printf "        %s.%s = %s;\n" pkg.name m.mname (tplize ctor v)
504               );
505               printf "        return 1;\n"
506           ) pkg.members;
507           printf "      default:\n";
508           printf "        return 1;\n";
509           printf "    }\n}\n";
510
511           (* dump methods *)
512           List.iter (do_func pkg) pkg.methods;
513           printf "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;
514           List.iter (function (f, _, _) ->
515               printf "    { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)
516             pkg.methods;
517           print_string (Str.global_replace (Str.regexp "%s") pkg.name
518 "    { NULL, NULL },
519 };
520
521 int luaopen_%s(lua_State *L)
522 {
523     int mt, methods;
524
525     %s_init();
526
527     /* create methods table, add it the the table of globals */
528     luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
529     methods = lua_gettop(L);
530
531     /* create metatable for %s, add it to the registry */
532     luaL_newmetatable(L, \"%s\");
533     mt = lua_gettop(L);
534
535     lua_pushliteral(L, \"__index\");
536     lua_pushvalue(L, mt);                       /* upvalue 1         */
537     lua_pushvalue(L, methods);                  /* upvalue 2         */
538     lua_pushcclosure(L, &luaM_%s_index, 2);
539     lua_rawset(L, mt);                          /* set mt.__index    */
540
541     lua_pushliteral(L, \"__newindex\");
542     lua_newtable(L);                            /* for new members   */
543     lua_pushcclosure(L, &luaM_%s_newindex, 1);
544     lua_rawset(L, mt);                          /* set mt.__newindex */
545
546     lua_pushliteral(L, \"__metatable\");
547     lua_pushvalue(L, methods);                  /* dup methods table */
548     lua_rawset(L, mt);                          /* hide metatable    */
549
550     lua_setmetatable(L, methods);
551
552     lua_pop(L, 2);                              /* drop mt + methods */
553     return 1;
554 }
555
556 ")
557     in List.iter do_c_aux
558
559 (* }}} *)
560
561   let usage () =
562     output_string stderr "usage: cpkg2c (-h | -c) file.cpkg\n";
563     exit 1
564
565   let _ =
566     let warn () = print_endline "/*** THIS FILE IS AUTOGENERATED !!! ***/" in
567     if Array.length Sys.argv <= 2 then usage();
568     let file   = Sys.argv.(2) in
569     let lexbuf = L.from_channel (open_in file) in
570     let l      = (startchunk cLine file lexbuf) in
571     match Sys.argv.(1) with
572     | "-h" -> warn (); do_h l
573     | "-c" -> warn (); do_c l
574     | _    -> usage ()
575 }