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