lib-lua/luapkg2c.pl

   1 #!/usr/bin/perl -w
   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 use strict;
  20
  21 my %types;
  22 my %pkgs;
  23
  24 #{{{ stream functions
  25
  26 sub stream_open($) {
  27     my $name = shift;
  28     open FILE, $name;
  29     return (file => $name, line => 0, f => \*FILE);
  30 }
  31
  32 sub stream_close($) {
  33     my $stream = shift;
  34     close $stream->{f};
  35 }
  36
  37 sub stream_getline($) {
  38     my $stream = shift;
  39     my $file   = $stream->{f};
  40     while (<$file>) {
  41         ${$stream}{line}++;
  42         return $_;
  43     }
  44     return;
  45 }
  46
  47 #}}}
  48
  49 #{{{ file:line functions
  50
  51 sub fatal($$) {
  52     my ($stream, $msg) = @_;
  53     printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg;
  54     exit 1;
  55 }
  56
  57 sub get_pos($$) {
  58     my ($h,$k) = @_;
  59     return $h->{$k}{file}.':'.$h->{$k}{line};
  60 }
  61
  62 sub put_line($$) {
  63     my ($src,$inc) = @_;
  64     printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file};
  65 }
  66
  67 #}}}
  68
  69 #{{{ parsers
  70
  71 sub parse_type($$) {
  72     my ($src, $type) = @_;
  73     my %t = (
  74         name => $type,
  75         file => $src->{file},
  76         line => $src->{line},
  77     );
  78
  79     if (defined $types{$type}) {
  80         my $pos = get_pos(\%types, $type);
  81         fatal($src, "already defined type: `$type' at $pos");
  82     }
  83
  84     while (stream_getline($src)) {
  85         last if (/^\s*\}\s*;\s*/);
  86         if (/^\s*\.(push|kind|ctype|dtor|ctor|check)\s*=\s*(.*?)\s*;\s*$/) {
  87             $t{$1} = $2;
  88             if ($1 eq "kind") {
  89                 if ($2 =~ /^'([bis])'$/) {
  90                     $t{kind} = $1;
  91                 } else {
  92                     fatal($src, "error: .kind should be [ibs] got $2)");
  93                 }
  94             }
  95         } elsif (!/^\s*$/) {
  96             fatal($src, "syntax error: unknown type directive");
  97         }
  98     }
  99
 100     for ('kind', 'ctype') {
 101         fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
 102     }
 103     if ($t{kind} eq 's') {
 104         for ('dtor', 'ctor') {
 105             fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
 106         }
 107     }
 108     unless (defined $t{check}) {
 109         if ($t{kind} eq 'b') {
 110             $t{check} = '(luaL_checkint($L, $$) == 0)';
 111         }
 112
 113         if ($t{kind} eq 'i') {
 114             $t{check} = 'luaL_checkint($L, $$)';
 115         }
 116
 117         if ($t{kind} eq 's') {
 118             $t{check} = 'luaL_checkstring($L, $$)';
 119         }
 120     }
 121
 122     $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/);
 123     $t{ctype} =~ s/:.*//;
 124
 125     return $types{$type} = \%t;
 126 }
 127
 128 sub parse_package($$) {
 129     my ($src, $pkg) = @_;
 130     my %p = (
 131         name => $pkg,
 132         file => $src->{file},
 133         line => $src->{line},
 134     );
 135
 136     if (defined $pkgs{$pkg}) {
 137         my $pos = get_pos(\%pkgs, $pkg);
 138         fatal($src, "already defined package: `$pkg' at $pos");
 139     }
 140
 141     while (stream_getline($src)) {
 142         if (/^\s*\}\s*(\w+)\s*;\s*$/) {
 143             $p{cname} = $1;
 144             last;
 145         }
 146
 147         if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
 148             my ($lhs, $rhs) = ($1, $2);
 149             my %m = ( file => $src->{file}, line => $src->{line} );
 150
 151             if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
 152                 $m{type} = $1;
 153                 $m{name} = $2;
 154                 $m{init} = $rhs;
 155                 push @{$p{props}}, $2;
 156             } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
 157                 $m{type}  = $1;
 158                 $m{name}  = $2;
 159                 $m{proto} = $3;
 160                 $m{cfun}  = $rhs;
 161                 push @{$p{meths}}, $2;
 162             } else {
 163                 fatal($src, "syntax error");
 164             }
 165
 166             if (defined $p{members}{$m{name}}) {
 167                 my $pos = get_pos($p{members}{$m{name}}, 0);
 168                 fatal($src, "already defined package member: `$m{name}' at $pos");
 169             }
 170
 171             $p{members}{$m{name}} = \%m;
 172             next;
 173         }
 174
 175         if (!/^\s*$/) {
 176             fatal($src, "syntax error");
 177         }
 178     }
 179
 180     return $pkgs{$pkg} = \%p;
 181 }
 182
 183 sub find_type($$) {
 184     my ($ref, $typ) = @_;
 185
 186     if ($typ =~ /^const\s+(\w*)$/) {
 187         fatal($ref, "undefined type `$1'") unless defined $types{$1};
 188         return (const => 1, type => $types{$1});
 189     }
 190
 191     fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
 192     return (const => 0, type => $types{$typ});
 193 }
 194
 195 #}}}
 196
 197 #{{{ dump_fun
 198
 199 sub dump_fun($$) {
 200     my ($pkg, $f) = @_;
 201     my %t    = find_type($f, $f->{type});
 202     my $call = $f->{cfun};
 203     $call =~ s/\$/var/;
 204
 205     print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";
 206
 207     if ($f->{proto} ne "void") {
 208         my $i = 1;
 209         for my $tmp (split /,/,$f->{proto}) {
 210             s/^\s+//;
 211             s/\s+$//;
 212
 213             my %pt = find_type($f, $tmp);
 214             my $check = $pt{type}->{check};
 215             $check =~ s/\$L/L/;
 216             $check =~ s/\$\$/\%d/;
 217
 218             put_line($pt{type}, 0);
 219             printf "    $pt{type}->{ctype} var$i = $check\n", $i++;
 220         }
 221     }
 222
 223     if (defined $t{type}->{push}) {
 224         $call =~ s/\$\$/$t{type}->{push}/;
 225     }
 226
 227     if ($t{type}->{kind} eq 'b') {
 228         put_line($f, 0);
 229         print "    lua_pushboolean(L, $call);\n";
 230     }
 231
 232     if ($t{type}->{kind} eq 'i') {
 233         put_line($f, 0);
 234         print "    lua_pushint(L, $call);\n";
 235     }
 236
 237     if ($t{type}->{kind} eq 's') {
 238         if ($t{const}) {
 239             put_line($f, 0);
 240             print "    lua_pushstring(L, $call);\n";
 241         } else {
 242             print "    {\n";
 243             put_line($f, 0);
 244             print "        char *s = $call;\n";
 245             print "        lua_pushstring(L, s);\n";
 246             print "        p_delete(&s);\n";
 247             print "    }\n";
 248         }
 249     }
 250
 251     printf "    return %d;\n", ($f->{type} ne "void");
 252     print "}\n";
 253 }
 254
 255 #}}}
 256
 257 #{{{ dump_struct
 258
 259 sub dump_struct_full($) {
 260     my ($pkg) = @_;
 261
 262     put_line($pkg, 0);
 263     print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";
 264
 265     foreach (@{$pkg->{props}}) {
 266         my $p = $pkg->{members}{$_};
 267         my %t = find_type($p, $p->{type});
 268
 269         if ($t{const}) {
 270             put_line($p, 0);
 271             print "    $p->{init},\n";
 272         } else {
 273             print "    0,\n"    if ($t{type}->{kind} eq 'b');
 274             print "    0,\n"    if ($t{type}->{kind} eq 'i');
 275             print "    NULL,\n" if ($t{type}->{kind} eq 's');
 276         }
 277     }
 278
 279     print <<EOF;
 280 };
 281
 282 static void $pkg->{cname}_init(void)
 283 {
 284 EOF
 285
 286     foreach (@{$pkg->{props}}) {
 287         my $p   = $pkg->{members}{$_};
 288         my %t   = find_type($p, $p->{type});
 289         my $var = $pkg->{cname}.".".$p->{name};
 290
 291         next if $t{const};
 292
 293         put_line($p, 0);
 294         if ($t{type}->{dtor}) {
 295             my $dtor = $t{type}->{dtor};
 296             $dtor =~ s/\$L/L/;
 297             $dtor =~ s/\$\$/\&$var/;
 298             print "    $dtor;\n";
 299         }
 300         print "    $var = $p->{init};\n"
 301     }
 302     print "};\n";
 303 };
 304
 305 sub dump_struct_short($) {
 306     my ($pkg) = @_;
 307
 308     print "struct luaM_$pkg->{name}_t {\n";
 309     foreach (@{$pkg->{props}}) {
 310         my $p = $pkg->{members}{$_};
 311         my %t = find_type($p, $p->{type});
 312         if ($t{const}) {
 313             printf "    const $t{type}->{ctypefmt};\n", $p->{name};
 314         } else {
 315             printf "    $t{type}->{ctypefmt};\n", $p->{name};
 316         }
 317     }
 318     put_line($pkg, 0);
 319     print <<EOF;
 320 };
 321
 322 extern struct luaM_$pkg->{name}_t $pkg->{cname};
 323 EOF
 324 }
 325
 326 sub dump_struct_static($) {
 327     my ($pkg) = @_;
 328
 329     print "static struct {\n";
 330     foreach (@{$pkg->{props}}) {
 331         my $p = $pkg->{members}{$_};
 332         my %t = find_type($p, $p->{type});
 333         if ($t{const}) {
 334             printf "    const $t{type}->{ctypefmt};\n", $p->{name};
 335         } else {
 336             printf "    $t{type}->{ctypefmt};\n", $p->{name};
 337         }
 338     }
 339     put_line($pkg, 0);
 340     print "} $pkg->{cname} = {\n";
 341
 342     foreach (@{$pkg->{props}}) {
 343         my $p = $pkg->{members}{$_};
 344         my %t = find_type($p, $p->{type});
 345
 346         if ($t{const}) {
 347             put_line($p, 0);
 348             print "    $p->{init},\n";
 349         } else {
 350             print "    0,\n"    if ($t{type}->{kind} eq 'b');
 351             print "    0,\n"    if ($t{type}->{kind} eq 'i');
 352             print "    NULL,\n" if ($t{type}->{kind} eq 's');
 353         }
 354     }
 355
 356     print <<EOF;
 357 };
 358
 359 static void $pkg->{cname}_init(void)
 360 {
 361 EOF
 362
 363     foreach (@{$pkg->{props}}) {
 364         my $p   = $pkg->{members}{$_};
 365         my %t   = find_type($p, $p->{type});
 366         my $var = $pkg->{cname}.".".$p->{name};
 367
 368         next if $t{const};
 369
 370         put_line($p, 0);
 371         if ($t{type}->{dtor}) {
 372             my $dtor = $t{type}->{dtor};
 373             $dtor =~ s/\$L/L/;
 374             $dtor =~ s/\$\$/\&$var/;
 375             print "    $dtor;\n";
 376         }
 377         print "    $var = $p->{init};\n"
 378     }
 379     print "};\n";
 380 };
 381
 382 #}}}
 383
 384 #{{{ dump package
 385
 386 sub dump_package_full($$) {
 387     my ($pkg, $static) = @_;
 388
 389     if ($static) {
 390         dump_struct_static($pkg);
 391     } else {
 392         dump_struct_full($pkg);
 393     }
 394     map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
 395     print <<EOF;
 396
 397 static const luaL_reg luaM_$pkg->{name}_methods[] = {
 398 EOF
 399     map { print "    { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
 400     print <<EOF;
 401     { NULL, NULL }
 402 };
 403
 404 static int luaM_$pkg->{name}_index(lua_State *L)
 405 {
 406     const char *idx = luaL_checkstring(L, 2);
 407
 408     switch (mlua_which_token(idx, -1)) {
 409 EOF
 410
 411     foreach (@{$pkg->{props}}) {
 412         my $p = $pkg->{members}{$_};
 413         my %t = find_type($p, $p->{type});
 414         my $call = $pkg->{cname}.".".$p->{name};
 415
 416         my $tok = $p->{name};
 417         $tok =~ tr/a-z/A-Z/;
 418
 419         if ($t{type}->{kind} eq 'b') {
 420             $call = "lua_pushboolean(L, $call)";
 421         }
 422
 423         if ($t{type}->{kind} eq 'i') {
 424             $call = "lua_pushinteger(L, $call)";
 425         }
 426
 427         if ($t{type}->{kind} eq 's') {
 428             $call = "lua_pushstring(L, $call)";
 429         }
 430
 431         if (defined $t{type}->{push}) {
 432             $call =~ s/\$\$/$t{type}->{push}/;
 433         }
 434
 435         put_line($p, 0);
 436         print  "      case LTK_$tok:\n";
 437         printf "        $call;\n";
 438         print  "        return 1;\n";
 439     }
 440
 441 print <<EOF;
 442       default:
 443         lua_rawget(L, lua_upvalueindex(2));       /* try methods       */
 444         return 1;
 445     }
 446 }
 447
 448 static int luaM_$pkg->{name}_newindex(lua_State *L)
 449 {
 450     const char *idx = luaL_checkstring(L, 2);
 451
 452     switch (mlua_which_token(idx, -1)) {
 453 EOF
 454
 455     foreach (@{$pkg->{props}}) {
 456         my $p = $pkg->{members}{$_};
 457         my %t = find_type($p, $p->{type});
 458
 459         next if ($t{const});
 460
 461         my $tok = $p->{name};
 462         my $var = $pkg->{cname}.".".$p->{name};
 463         my $check = $t{type}->{check};
 464         $tok   =~ tr/a-z/A-Z/;
 465         $check =~ s/\$L/L/;
 466         $check =~ s/\$\$/3/;
 467
 468         put_line($p, 0);
 469         print  "      case LTK_$tok: \n";
 470         if ($t{type}->{dtor}) {
 471             my $dtor = $t{type}->{dtor};
 472             $dtor =~ s/\$L/L/;
 473             $dtor =~ s/\$\$/\&$var/;
 474             print "        $dtor;\n";
 475         }
 476         if ($t{type}->{ctor}) {
 477             my $ctor = $t{type}->{ctor};
 478             $ctor =~ s/\$L/L/;
 479             $ctor =~ s/\$\$/$check/;
 480             $check = $ctor;
 481         }
 482         print "        $var = $check;\n";
 483         print "        return 1;\n";
 484     }
 485
 486 print <<EOF;
 487       default:
 488         return 1;
 489     }
 490 }
 491
 492 int luaopen_$pkg->{name}(lua_State *L)
 493 {
 494     int mt, methods;
 495
 496     $pkg->{cname}_init();
 497
 498     /* create methods table, add it the the table of globals */
 499     luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0);
 500     methods = lua_gettop(L);
 501
 502     /* create metatable for $pkg->{name}, add it to the registry */
 503     luaL_newmetatable(L, "$pkg->{name}");
 504     mt = lua_gettop(L);
 505
 506     lua_pushliteral(L, "__index");
 507     lua_pushvalue(L, mt);                       /* upvalue 1         */
 508     lua_pushvalue(L, methods);                  /* upvalue 2         */
 509     lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2);
 510     lua_rawset(L, mt);                          /* set mt.__index    */
 511
 512     lua_pushliteral(L, "__newindex");
 513     lua_newtable(L);                            /* for new members   */
 514     lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1);
 515     lua_rawset(L, mt);                          /* set mt.__newindex */
 516
 517     lua_pushliteral(L, "__metatable");
 518     lua_pushvalue(L, methods);                  /* dup methods table */
 519     lua_rawset(L, mt);                          /* hide metatable    */
 520
 521     lua_setmetatable(L, methods);
 522
 523     lua_pop(L, 1);                              /* drop mt           */
 524     return 1;                                   /* return methods    */
 525 }
 526
 527 EOF
 528 }
 529
 530 sub dump_package_short($) {
 531     my $pkg = shift;
 532     my $upp = $pkg->{name};
 533     $upp =~ tr/a-z/A-Z/;
 534
 535     print <<EOF;
 536 #ifndef MUTT_LUA_${upp}_H
 537 #define MUTT_LUA_${upp}_H
 538
 539 EOF
 540     dump_struct_short($pkg);
 541     print <<EOF
 542
 543 int luaopen_$pkg->{name}(lua_State *L);
 544
 545 #endif /* MUTT_LUA_${upp}_H */
 546 EOF
 547 }
 548
 549 #}}}
 550
 551 sub do_c($) {
 552     my %src = stream_open(shift);
 553     my $resync = 1;
 554
 555     while (stream_getline(\%src)) {
 556         if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
 557             parse_type(\%src, $1);
 558             $resync = 1;
 559         } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
 560             dump_package_full(parse_package(\%src, $1), 1);
 561             $resync = 1;
 562         } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
 563             dump_package_full(parse_package(\%src, $1), 0);
 564             $resync = 1;
 565         } elsif (/^\s*(\@\w*)/) {
 566             fatal(\%src, "syntax error: unknown directive `$1'");
 567         } else {
 568             next if ($resync && /^\s+$/);
 569             if ($resync) {
 570                 put_line(\%src, 0);
 571                 $resync = 0;
 572             }
 573             print;
 574         }
 575     }
 576
 577     stream_close(\%src);
 578 }
 579
 580 sub do_h($) {
 581     my %src = stream_open(shift);
 582     my $resync = 1;
 583
 584     while (stream_getline(\%src)) {
 585         if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
 586             parse_type(\%src, $1);
 587         } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
 588             dump_package_short(parse_package(\%src, $1));
 589         } elsif (/^\s*(\@\w*)/) {
 590             fatal(\%src, "syntax error: unknown directive `$1'");
 591         }
 592     }
 593
 594     stream_close(\%src);
 595 }
 596
 597 if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
 598     print <<EOF;
 599 usage: mluapkg (-h | -c) file.pkg
 600 EOF
 601     exit 1;
 602 }
 603
 604 print <<EOF;
 605 /*****     THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY !    *****/
 606 EOF
 607
 608 map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
 609 map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');