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