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;
  76       init: string anchor; onchange: string anchor option; }
  77   let member0 =
  78     { typ   = false, typedef0;
  79       mname = "";
  80       init = "", "", 0;
  81       onchange = None;
  82     }
  83
  84   type methods =
  85     { rettype: typinst list; args: (typinst * string) list;
  86       fname: string; body: string }
  87
  88   type package =
  89     { line: int; file: string; name: string;
  90       members: members anchor list;
  91       methods: methods anchor list;
  92       static: bool;
  93     }
  94
  95   let newpkg lpos fpos name static =
  96     { static = static; line = lpos; file = fpos; name = name; members = []; methods = []; }
  97
  98   let type_find lpos fpos t =
  99     try Hashtbl.find types t
 100     with Not_found -> die lpos fpos (sprintf "Unknown type `%s'" t)
 101
 102   let parse_rettype lpos fpos s =
 103     let aux t =
 104       match Str.split (Str.regexp "[ \t]+") t with
 105       | ["const"; t] -> (true,  type_find lpos fpos t)
 106       | [t]          -> (false, type_find lpos fpos t)
 107       | _ -> assert false
 108     in
 109     match strip s with
 110     | "void" -> []
 111     | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
 112
 113   let parse_args lpos fpos s =
 114     let aux t =
 115       match Str.split (Str.regexp "[ \t]+") t with
 116       | ["const"; t; n] -> ((true,  type_find lpos fpos t), n)
 117       | [t; n]          -> ((false, type_find lpos fpos t), n)
 118       | _ -> assert false
 119     in
 120     match strip s with
 121     | "void" -> []
 122     | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
 123
 124 (* }}} *)
 125 (* parsing helpers {{{ *)
 126
 127   type stanza = Buf of string anchor | Pkg of package
 128
 129   let nextl lexbuf =
 130     let pos = lexbuf.L.lex_curr_p in
 131     lexbuf.L.lex_curr_p <-
 132       { pos with
 133         L.pos_lnum = pos.L.pos_lnum + 1;
 134         L.pos_bol  = pos.L.pos_cnum; };
 135     lexbuf
 136   ;;
 137
 138   let lnum lexbuf = lexbuf.L.lex_curr_p.L.pos_lnum
 139
 140   let (@.)  buf s = B.add_string buf s; buf
 141   let (@<)  buf c = B.add_char   buf c; buf
 142
 143   let getchunk lpos fpos buf lexbuf =
 144     let res = B.contents buf in
 145     B.clear buf;
 146     Buf(res, fpos, lpos)
 147
 148   let startchunk f fpos lexbuf =
 149     f (lnum lexbuf) fpos (B.create 4096) lexbuf
 150
 151   let newchunk f lpos fpos buf lexbuf =
 152     let res = getchunk lpos fpos buf lexbuf in
 153     res::(f (lnum lexbuf, fpos) buf lexbuf)
 154
 155   let find_import relpath file =
 156     if Filename.is_relative file then
 157       match Filename.dirname relpath with
 158       | "." -> file
 159       | s   -> Filename.concat s file
 160     else
 161       file
 162
 163 (* }}} *)
 164 }
 165
 166 (* regex aliases {{{ *)
 167
 168 let to_eol = [^'\n']* '\n'
 169 let ident  = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''_''0'-'9']*
 170 let sp     = [' ''\t']
 171
 172 let typdecl = sp* ("const" sp+)? ident sp*
 173
 174 (* }}} *)
 175 (* entry point {{{ *)
 176
 177 rule cLine lpos fpos buf = parse
 178 | sp* "@type" sp+ (ident as id) sp* (':' sp* (ident as id0) sp*)? '{'
 179                     {
 180                       let line = lnum lexbuf in
 181                       let t0 = match id0 with
 182                       | None     -> typedef0
 183                       | Some id0 ->
 184                           try H.find types id0
 185                           with Not_found ->
 186                             die line fpos (sprintf "Uknown type `%s'" id0)
 187                       in try
 188                         let t = H.find types id in
 189                         die line fpos
 190                           (sprintf "type `%s' already defined at %s:%d"
 191                             id t.fpos t.lpos)
 192                       with Not_found ->
 193                         (getchunk lpos fpos buf lexbuf) :: (
 194                           ext_type id {t0 with lpos = line; fpos = fpos}
 195                             lexbuf
 196                         )
 197                     }
 198 | sp* "@import" sp+ '"' ([^'"''\n']* as file) '"' sp* '\n'
 199                     {
 200                       let file = find_import fpos file in
 201                       let _ = startchunk cLine file
 202                                 (L.from_channel (open_in file)) in
 203                       cLine lpos fpos (buf @< '\n') (nextl lexbuf)
 204                     }
 205 | sp* ("@package"|"@static_package" as kw) sp+ (ident as pkg) sp* '{'
 206                     {
 207                       let a = getchunk lpos fpos buf lexbuf in
 208                       let line = lnum lexbuf in
 209                       a::(ext_pkg (newpkg line fpos pkg
 210                                     (kw = "@static_package")) lexbuf)
 211                     }
 212 | sp* '@'           { die (lnum lexbuf) fpos "Syntax error" }
 213 | sp* '#' as s      { let buf = cPP (buf @. s) lexbuf in
 214                       cLine lpos fpos buf lexbuf }
 215 | ""                { let buf = cCode buf lexbuf in
 216                       cLine lpos fpos buf lexbuf }
 217 | eof               { [getchunk lpos fpos buf lexbuf] }
 218
 219 (* }}} *)
 220 (* cCode block parser {{{ *)
 221
 222 and cCode buf = parse
 223 | '\n'    as c      { let _ = nextl lexbuf in buf @< c }
 224 | '"'     as c      { let buf = cString (buf @< c) lexbuf in
 225                       cCode buf lexbuf }
 226 | "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
 227                       cCode buf lexbuf }
 228 | "//" to_eol as s  { cCode (buf @. s) (nextl lexbuf) }
 229 | "'\"'"  as s      { cCode (buf @. s) lexbuf }
 230 | _       as c      { cCode (buf @< c) lexbuf }
 231
 232 (* }}} *)
 233 (* helper rules: comment, string, cPP {{{ *)
 234
 235 and cComment buf = parse
 236 | "*/"    as s { buf @. s }
 237 | '\n'    as c { cComment (buf @< c) (nextl lexbuf) }
 238 | _       as c { cComment (buf @< c) lexbuf }
 239
 240 and cString buf = parse
 241 | '"'     as c { buf @< c }
 242 | "\\\""  as s { cString (buf @. s) lexbuf }
 243 | "\\\n"  as s { cString (buf @. s) (nextl lexbuf) }
 244 | [^'\n'] as c { cString (buf @< c) lexbuf }
 245
 246 and cPP buf = parse
 247 | [^'\n']* "\\\n" as s { cPP (buf @. s) (nextl lexbuf) }
 248 | to_eol          as s { let _ = nextl lexbuf in buf @. s }
 249
 250 (* }}} *)
 251 (* parse @type {{{ *)
 252
 253 and ext_type id typ = parse
 254 | sp+
 255 | "//" to_eol       { ext_type id typ lexbuf }
 256 | '\n'              { ext_type id typ (nextl lexbuf) }
 257 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
 258                       ext_type id typ lexbuf }
 259 | '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
 260                     {
 261                       ext_type id (
 262                         let do_anch s = s, typ.fpos, lnum lexbuf in
 263                         match member with
 264                         | "ctype" -> {typ with ctype = do_anch s}
 265                         | "check" -> {typ with check = do_anch s}
 266                         | "push"  -> {typ with push  = do_anch s}
 267                         | "ctor"  -> {typ with ctor  = Some (do_anch s)}
 268                         | "dtor"  -> {typ with dtor  = Some (do_anch s)}
 269                         | _       ->
 270                             die (lnum lexbuf) typ.fpos
 271                               (sprintf "Unknown directive `%s'" member)
 272                       ) lexbuf
 273                     }
 274 | '}' sp* ';' (sp* '\n' as s)?
 275                     { id @:= typ; startchunk cLine typ.fpos
 276                       (if s = None then lexbuf else nextl lexbuf) }
 277 | ""                { die (lnum lexbuf) typ.fpos "Syntax error" }
 278
 279 (* }}} *)
 280 (* parse @package {{{ *)
 281
 282 and ext_pkg pkg = parse
 283 | sp+
 284 | "//" to_eol       { ext_pkg pkg lexbuf }
 285 | '\n'              { ext_pkg pkg (nextl lexbuf) }
 286 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
 287                       ext_pkg pkg lexbuf }
 288 | ("const" sp+ as const)? (ident as typ) sp+
 289   (ident as member) sp* '=' sp* '{'
 290                     {
 291                       let m = {member0 with mname = member;
 292                                typ = const != None, type_find (lnum lexbuf)
 293                                pkg.file typ; } in
 294                       let m = ext_member m pkg.file lexbuf in
 295                       ext_pkg {pkg with members = (m, pkg.file, lnum lexbuf)::pkg.members} lexbuf
 296                     }
 297 | ("const" sp+ as const)? (ident as typ) sp+
 298   (ident as member) sp* '=' sp* ([^';''\n']* as init)';'
 299                     {
 300                       let m = { typ   = const != None,
 301                                         type_find (lnum lexbuf) pkg.file typ;
 302                                 mname = member;
 303                                 init  = init, pkg.file, lnum lexbuf;
 304                                 onchange = None; }, pkg.file, lnum lexbuf in
 305                       ext_pkg {pkg with members = m::pkg.members} lexbuf
 306                     }
 307 | '(' ((typdecl ',')* typdecl as ret) ')' sp*
 308    (ident as fname)
 309    '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
 310 | (typdecl as ret) (ident as fname)
 311    '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
 312                     {
 313                       let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
 314                       let args    = parse_args    (lnum lexbuf) pkg.file args in
 315                       let f, l    = pkg.file, lnum lexbuf in
 316                       let body    = ext_body pkg (B.create 1024) lexbuf in
 317                       let m       = { rettype = rettype;
 318                                       args = args;
 319                                       fname = fname;
 320                                       body = body }, f, l in
 321                       ext_pkg {pkg with methods = m::pkg.methods} lexbuf
 322                     }
 323 | '}' sp* ';' (sp* '\n' as s)?
 324                     { Pkg({pkg with members = List.rev(pkg.members)}) :: (
 325                         startchunk cLine pkg.file
 326                         (if s = None then lexbuf else nextl lexbuf)
 327                       )
 328                     }
 329 | ""                { die (lnum lexbuf) pkg.file "Syntax error" }
 330
 331 and ext_body pkg buf = parse
 332 | sp+         as s
 333 | "//" to_eol as s  { ext_body pkg (buf @. s) lexbuf }
 334 | '\n'        as c  { ext_body pkg (buf @< c) lexbuf }
 335 | "/*"              { let buf = cComment (buf @. "/*") lexbuf in
 336                       ext_body pkg buf lexbuf }
 337 | ';'               { B.contents buf }
 338 | '{'         as c  { let buf = ext_bodycode (buf @< c) lexbuf in
 339                       ext_body pkg buf lexbuf }
 340 | ""                { die (lnum lexbuf) pkg.file "Syntax error" }
 341
 342 and ext_bodycode buf = parse
 343 | '\n'    as c      { ext_bodycode (buf @< c) (nextl lexbuf) }
 344 | '"'     as c      { let buf = cString (buf @< c) lexbuf in
 345                       ext_bodycode buf lexbuf }
 346 | "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
 347                       ext_bodycode buf lexbuf }
 348 | "//" to_eol as s  { ext_bodycode (buf @. s) (nextl lexbuf) }
 349 | "'\"'"  as s      { ext_bodycode (buf @. s) lexbuf }
 350 | '{'     as c      { let buf = ext_bodycode (buf @< c) lexbuf in ext_bodycode buf lexbuf }
 351 | '}'     as c      { buf @< c }
 352 | _       as c      { ext_bodycode (buf @< c) lexbuf }
 353
 354 (* }}} *)
 355 (* parse extended member {{{ *)
 356
 357 and ext_member m f = parse
 358 | sp+
 359 | "//" to_eol       { ext_member m f lexbuf }
 360 | '\n'              { ext_member m f (nextl lexbuf) }
 361 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
 362                       ext_member m f lexbuf }
 363 | '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
 364                     {
 365                       ext_member (
 366                         let do_anch s = s, f, lnum lexbuf in
 367                         match member with
 368                         | "init"     -> {m with init = do_anch s}
 369                         | "onchange" -> {m with onchange = Some(do_anch s)}
 370                         | _       ->
 371                             die (lnum lexbuf) f
 372                               (sprintf "Unknown directive `%s'" member)
 373                       ) f lexbuf
 374                     }
 375 | '}' sp* ';'       { m }
 376 | ""                { die (lnum lexbuf) f "Syntax error" }
 377
 378 (* }}} *)
 379
 380 {
 381 (* templating functions {{{ *)
 382
 383   let upper = String.uppercase
 384   let tplize tpl v =
 385     Str.global_replace (Str.regexp_string "$L") "L" (
 386       Str.global_replace (Str.regexp_string "$$") v tpl
 387     )
 388
 389   let dump_struct_type begwith pkg endwith =
 390     printf "%sstruct luaM_%s_t {\n" begwith pkg.name;
 391     List.iter (function (m, f, l) ->
 392       put_line l f;
 393       let ctype = t1 (snd m.typ).ctype in
 394       print_string "    ";
 395       if fst m.typ then print_string "const ";
 396       let i = try String.index ctype ':' with Not_found -> String.length ctype in
 397       printf "%s %s%s;\n" (Str.string_before ctype i)
 398         m.mname (Str.string_after ctype i)
 399     ) pkg.members;
 400     print_endline ("}" ^ endwith)
 401
 402   let do_h =
 403     let do_h_aux = function
 404       | Buf _ -> ()
 405       | Pkg pkg ->
 406           printf "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
 407           printf "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);
 408           if not pkg.static then (
 409             dump_struct_type "" pkg ";";
 410             printf "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;
 411           );
 412           printf "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
 413           printf "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
 414     in List.iter do_h_aux
 415
 416   let do_func pkg (fn, f, l) =
 417     (* return inline function *)
 418     printf "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;
 419     let retlen = List.fold_left (fun i t ->
 420       let i = i + 1 in
 421       match t with
 422       | true, typ -> printf ", const %s luaM_x%d" (t1 typ.ctype) i; i
 423       | false, typ -> printf ", %s luaM_x%d" (t1 typ.ctype) i; i
 424       ) 0 fn.rettype in
 425     printf ")\n{\n";
 426     ignore (List.fold_left (fun i (const, typ) ->
 427       let i = i + 1 in
 428       let (p, f, l) = typ.push in
 429       put_line l f;
 430       printf "    %s;\n" (tplize p (sprintf "luaM_x%d" i));
 431       if not const then (
 432         match typ.dtor with
 433         | None             -> ()
 434         | Some(dtor, f, l) ->
 435             put_line l f;
 436             printf "    %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))
 437       ); i
 438     ) 0 fn.rettype) ;
 439     printf "    return %d;\n}\n" retlen;
 440
 441     (* main function *)
 442     printf "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
 443     ignore (List.fold_left (fun i ((const, typ), name) ->
 444       let i = i + 1 in
 445       let ctype = t1 typ.ctype in
 446       if const then (
 447         let (c, f, l) = typ.check in
 448         put_line l f;
 449         printf "    const %s %s = %s;\n" ctype name (tplize c (string_of_int i))
 450       ) else (
 451         match typ.ctor with
 452         | None ->
 453           let (c, f, l) = typ.check in
 454           put_line l f;
 455           printf "    %s %s = %s;\n" ctype name (tplize c (string_of_int i))
 456         | Some (ctor, f, l) ->
 457           let v =
 458             let c, f, l = typ.check in
 459             tplize (sprintf "\n#line %d \"%s\"\n        %s" l f c)
 460               (string_of_int i)
 461           in
 462           put_line l f;
 463           printf "    %s %s = %s;\n" ctype name (tplize ctor v)
 464       ); i
 465     ) 0 fn.args);
 466     printf "\n#define RAISE(s)  luaL_error(L, (s))\n";
 467     if fn.rettype = [] then (
 468       printf "#define RETURN()  return luaM_ret_%s_%s(L)\n" pkg.name fn.fname
 469     ) else (
 470       printf "#define RETURN(luaM_x1";
 471       for i = 2 to retlen do printf ", luaM_x%d" i done;
 472       printf ") \\\n        return luaM_ret_%s_%s(L" pkg.name fn.fname;
 473       for i = 1 to retlen do printf ", luaM_x%d" i done;
 474       printf ")\n"
 475     );
 476     put_line l f;
 477     printf "    %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body
 478
 479   let do_c =
 480     let do_c_aux = function
 481       | Buf (s, f, l) -> put_line l f; print_string s
 482       | Pkg pkg       ->
 483           (* dump struct const init *)
 484           (if pkg.static then
 485             dump_struct_type "static " pkg (sprintf " %s = {\n" pkg.name)
 486           else
 487             printf "struct luaM_%s_t %s = {\n" pkg.name pkg.name
 488           );
 489           List.iter (function (m, _, _) ->
 490               let (init, f, l) = m.init in
 491               put_line l f;
 492               printf "    %s,\n" (if fst m.typ then init else "0")
 493             ) pkg.members;
 494           printf "};\n";
 495
 496           (* dump struct init func *)
 497           printf "\nstatic void %s_init(void)\n{\n" pkg.name;
 498           List.iter (function (m, _, _) ->
 499             if not (fst m.typ) then
 500               let init, f, l = m.init in
 501               let field = sprintf "%s.%s" pkg.name m.mname in
 502               put_line l f;
 503               printf "    %s = %s;\n" field init;
 504               match m.onchange with
 505               | None           -> ()
 506               | Some(on, f, l) ->
 507                   put_line l f; printf "    %s;\n" (tplize on field)
 508             ) pkg.members;
 509           printf "};\n\n";
 510
 511           (* dump __index *)
 512           printf "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
 513           printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
 514           printf "    switch (mlua_which_token(idx, -1)) {\n";
 515           List.iter (function (m, _, _) ->
 516             printf "      case LTK_%s:\n" (upper m.mname);
 517             let push, f, l = (snd m.typ).push in
 518             put_line l f;
 519             printf "        %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
 520             printf "        return 1;\n"
 521           ) pkg.members;
 522           printf "      default:\n";
 523           printf "        lua_rawget(L, lua_upvalueindex(1));\n";
 524           printf "        return 1;\n";
 525           printf "    }\n}\n\n";
 526
 527           (* dump __newindex *)
 528           printf "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
 529           printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
 530           printf "    switch (mlua_which_token(idx, -1)) {\n";
 531           List.iter (function (m, _, _) ->
 532             let field = sprintf "%s.%s" pkg.name m.mname in
 533             match m.typ with
 534             | true, _ -> ()
 535             | false, t ->
 536               printf "      case LTK_%s:\n" (upper m.mname);
 537               (match t.dtor with
 538               | None -> ()
 539               | Some (dtor, f, l) ->
 540                   put_line l f;
 541                   printf "        %s;\n" (tplize dtor ("&" ^ field))
 542               );
 543               (match t.ctor with
 544               | None ->
 545                   let (c, f, l) = t.check in
 546                   put_line l f;
 547                   printf "        %s = %s;\n" field (tplize c "3")
 548               | Some (ctor, f, l) ->
 549                   let v =
 550                     let c, f, l = t.check in
 551                     tplize (sprintf "\n#line %d \"%s\"\n            %s" l f c) "3"
 552                   in
 553                   put_line l f;
 554                   printf "        %s = %s;\n" field (tplize ctor v)
 555               );
 556               (match m.onchange with
 557               | None           -> ()
 558               | Some(on, f, l) ->
 559                   put_line l f;
 560                   printf "        %s;\n" (tplize on field)
 561               );
 562               printf "        return 1;\n"
 563           ) pkg.members;
 564           printf "      default:\n";
 565           printf "        lua_rawset(L, lua_upvalueindex(1));\n";
 566           printf "        return 1;\n";
 567           printf "    }\n}\n";
 568
 569           (* dump methods *)
 570           List.iter (do_func pkg) pkg.methods;
 571           printf "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;
 572           List.iter (function (f, _, _) ->
 573               printf "    { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)
 574             pkg.methods;
 575           print_string (Str.global_replace (Str.regexp "%s") pkg.name
 576 "    { NULL, NULL },
 577 };
 578
 579 int luaopen_%s(lua_State *L)
 580 {
 581     int mt, members, methods;
 582
 583     %s_init();
 584
 585     /* create methods table, add it the the table of globals */
 586     luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
 587     methods = lua_gettop(L);
 588
 589     lua_newtable(L);                            /* for new members   */
 590     members = lua_gettop(L);
 591
 592     /* create metatable for %s, add it to the registry */
 593     luaL_newmetatable(L, \"%s\");
 594     mt = lua_gettop(L);
 595
 596     lua_pushliteral(L, \"__index\");
 597     lua_pushvalue(L, members);                  /* upvalue  1        */
 598     lua_pushcclosure(L, &luaM_%s_index, 1);
 599     lua_rawset(L, mt);                          /* set mt.__index    */
 600
 601     lua_pushliteral(L, \"__newindex\");
 602     lua_pushvalue(L, members);                  /* upvalue  1        */
 603     lua_pushcclosure(L, &luaM_%s_newindex, 1);
 604     lua_rawset(L, mt);                          /* set mt.__newindex */
 605
 606     lua_pushliteral(L, \"__metatable\");
 607     lua_pushvalue(L, methods);                  /* dup methods table */
 608     lua_rawset(L, mt);                          /* hide metatable    */
 609
 610     lua_setmetatable(L, methods);
 611
 612     lua_pop(L, 3);
 613     return 1;
 614 }
 615
 616 ")
 617     in List.iter do_c_aux
 618
 619 (* }}} *)
 620
 621   let usage () =
 622     output_string stderr "usage: cpkg2c (-h | -c) file.cpkg\n";
 623     exit 1
 624
 625   let _ =
 626     let warn () = print_endline "/*** THIS FILE IS AUTOGENERATED !!! ***/" in
 627     if Array.length Sys.argv <= 2 then usage();
 628     let file   = Sys.argv.(2) in
 629     let lexbuf = L.from_channel (open_in file) in
 630     let l      = (startchunk cLine file lexbuf) in
 631     match Sys.argv.(1) with
 632     | "-h" -> warn (); do_h l
 633     | "-c" -> warn (); do_c l
 634     | _    -> usage ()
 635 }