X-Git-Url: http://git.madism.org/?p=apps%2Fmadmutt.git;a=blobdiff_plain;f=lib-lua%2Fluapkg2c.pl;fp=lib-lua%2Fluapkg2c.pl;h=0000000000000000000000000000000000000000;hp=f1bab327825cb4a4961f773bd23251a65fe5df28;hb=2dc50decd320b310ef56c14041b6fa4fefd865ac;hpb=597020b9829312a50c15784916f473da9e75efd0 diff --git a/lib-lua/luapkg2c.pl b/lib-lua/luapkg2c.pl deleted file mode 100755 index f1bab32..0000000 --- a/lib-lua/luapkg2c.pl +++ /dev/null @@ -1,606 +0,0 @@ -#!/usr/bin/perl -w -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or (at -# your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, -# MA 02110-1301, USA. -# -# Copyright © 2007 Pierre Habouzit - -use strict; - -my %types; -my %pkgs; - -#{{{ stream functions - -sub stream_open($) { - my $name = shift; - open FILE, $name; - return (file => $name, line => 0, f => \*FILE); -} - -sub stream_close($) { - my $stream = shift; - close $stream->{f}; -} - -sub stream_getline($) { - my $stream = shift; - my $file = $stream->{f}; - while (<$file>) { - ${$stream}{line}++; - return $_; - } - return; -} - -#}}} - -#{{{ file:line functions - -sub fatal($$) { - my ($stream, $msg) = @_; - printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg; - exit 1; -} - -sub get_pos($$) { - my ($h,$k) = @_; - return $h->{$k}{file}.':'.$h->{$k}{line}; -} - -sub put_line($$) { - my ($src,$inc) = @_; - printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file}; -} - -#}}} - -#{{{ parsers - -sub parse_type($$) { - my ($src, $type) = @_; - my %t = ( - name => $type, - file => $src->{file}, - line => $src->{line}, - ); - - if (defined $types{$type}) { - my $pos = get_pos(\%types, $type); - fatal($src, "already defined type: `$type' at $pos"); - } - - while (stream_getline($src)) { - last if (/^\s*\}\s*;\s*/); - if (/^\s*\.(kind|ctype|dtor|ctor|push|check)\s*=\s*(.*?)\s*;\s*$/) { - $t{$1} = $2; - if ($1 eq "kind") { - if ($2 =~ /^'([bis])'$/) { - $t{kind} = $1; - } else { - fatal($src, "error: .kind should be [ibs] got $2)"); - } - } - } elsif (!/^\s*$/) { - fatal($src, "syntax error: unknown type directive"); - } - } - - for ('kind', 'ctype') { - fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_}; - } - if ($t{kind} eq 's') { - for ('dtor', 'ctor') { - fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_}; - } - } - unless (defined $t{check}) { - if ($t{kind} eq 'b') { - $t{check} = '(luaL_checkint($L, $$) == 0)'; - } - - if ($t{kind} eq 'i') { - $t{check} = 'luaL_checkint($L, $$)'; - } - - if ($t{kind} eq 's') { - $t{check} = 'luaL_checkstring($L, $$)'; - } - } - - $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/); - $t{ctype} =~ s/:.*//; - - return $types{$type} = \%t; -} - -sub parse_package($$) { - my ($src, $pkg) = @_; - my %p = ( - name => $pkg, - file => $src->{file}, - line => $src->{line}, - ); - - if (defined $pkgs{$pkg}) { - my $pos = get_pos(\%pkgs, $pkg); - fatal($src, "already defined package: `$pkg' at $pos"); - } - - while (stream_getline($src)) { - if (/^\s*\}\s*(\w+)\s*;\s*$/) { - $p{cname} = $1; - last; - } - - if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) { - my ($lhs, $rhs) = ($1, $2); - my %m = ( file => $src->{file}, line => $src->{line} ); - - if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) { - $m{type} = $1; - $m{name} = $2; - $m{init} = $rhs; - push @{$p{props}}, $2; - } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) { - $m{type} = $1; - $m{name} = $2; - $m{proto} = $3; - $m{cfun} = $rhs; - push @{$p{meths}}, $2; - } else { - fatal($src, "syntax error"); - } - - if (defined $p{members}{$m{name}}) { - my $pos = get_pos($p{members}{$m{name}}, 0); - fatal($src, "already defined package member: `$m{name}' at $pos"); - } - - $p{members}{$m{name}} = \%m; - next; - } - - if (!/^\s*$/) { - fatal($src, "syntax error"); - } - } - - return $pkgs{$pkg} = \%p; -} - -sub find_type($$) { - my ($ref, $typ) = @_; - - if ($typ =~ /^const\s+(\w*)$/) { - fatal($ref, "undefined type `$1'") unless defined $types{$1}; - return (const => 1, type => $types{$1}); - } - - fatal($ref, "undefined type `$typ'") unless defined $types{$typ}; - return (const => 0, type => $types{$typ}); -} - -#}}} - -#{{{ dump_fun - -sub dump_fun($$) { - my ($pkg, $f) = @_; - my %t = find_type($f, $f->{type}); - my $call = $f->{cfun}; - $call =~ s/\$/var/; - - print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n"; - - if ($f->{proto} ne "void") { - my $i = 1; - for my $tmp (split /,/,$f->{proto}) { - s/^\s+//; - s/\s+$//; - - my %pt = find_type($f, $tmp); - my $check = $pt{type}->{check}; - $check =~ s/\$L/L/; - $check =~ s/\$\$/\%d/; - - put_line($pt{type}, 0); - printf " $pt{type}->{ctype} var$i = $check\n", $i++; - } - } - - die "UNIMPLEMENTED" if defined $t{type}->{push}; - - if ($t{type}->{kind} eq 'b') { - put_line($f, 0); - print " lua_pushboolean(L, $call);\n"; - } - - if ($t{type}->{kind} eq 'i') { - put_line($f, 0); - print " lua_pushint(L, $call);\n"; - } - - if ($t{type}->{kind} eq 's') { - if ($t{const}) { - put_line($f, 0); - print " lua_pushstring(L, $call);\n"; - } else { - print " {\n"; - put_line($f, 0); - print " char *s = $call;\n"; - print " lua_pushstring(L, s);\n"; - print " p_delete(&s);\n"; - print " }\n"; - } - } - - printf " return %d;\n", ($f->{type} ne "void"); - print "}\n"; -} - -#}}} - -#{{{ dump_struct - -sub dump_struct_full($) { - my ($pkg) = @_; - - put_line($pkg, 0); - print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n"; - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - - if ($t{const}) { - put_line($p, 0); - print " $p->{init},\n"; - } else { - print " 0,\n" if ($t{type}->{kind} eq 'b'); - print " 0,\n" if ($t{type}->{kind} eq 'i'); - print " NULL,\n" if ($t{type}->{kind} eq 's'); - } - } - - print <{cname}_init(void) -{ -EOF - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - my $var = $pkg->{cname}.".".$p->{name}; - - next if $t{const}; - - put_line($p, 0); - if ($t{type}->{dtor}) { - my $dtor = $t{type}->{dtor}; - $dtor =~ s/\$L/L/; - $dtor =~ s/\$\$/\&$var/; - print " $dtor;\n"; - } - print " $var = $p->{init};\n" - } - print "};\n"; -}; - -sub dump_struct_short($) { - my ($pkg) = @_; - - print "struct luaM_$pkg->{name}_t {\n"; - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - if ($t{const}) { - printf " const $t{type}->{ctypefmt};\n", $p->{name}; - } else { - printf " $t{type}->{ctypefmt};\n", $p->{name}; - } - } - put_line($pkg, 0); - print <{name}_t $pkg->{cname}; -EOF -} - -sub dump_struct_static($) { - my ($pkg) = @_; - - print "static struct {\n"; - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - if ($t{const}) { - printf " const $t{type}->{ctypefmt};\n", $p->{name}; - } else { - printf " $t{type}->{ctypefmt};\n", $p->{name}; - } - } - put_line($pkg, 0); - print "} $pkg->{cname} = {\n"; - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - - if ($t{const}) { - put_line($p, 0); - print " $p->{init},\n"; - } else { - print " 0,\n" if ($t{type}->{kind} eq 'b'); - print " 0,\n" if ($t{type}->{kind} eq 'i'); - print " NULL,\n" if ($t{type}->{kind} eq 's'); - } - } - - print <{cname}_init(void) -{ -EOF - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - my $var = $pkg->{cname}.".".$p->{name}; - - next if $t{const}; - - put_line($p, 0); - if ($t{type}->{dtor}) { - my $dtor = $t{type}->{dtor}; - $dtor =~ s/\$L/L/; - $dtor =~ s/\$\$/\&$var/; - print " $dtor;\n"; - } - print " $var = $p->{init};\n" - } - print "};\n"; -}; - -#}}} - -#{{{ dump package - -sub dump_package_full($$) { - my ($pkg, $static) = @_; - - if ($static) { - dump_struct_static($pkg); - } else { - dump_struct_full($pkg); - } - map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}}; - print <{name}_methods[] = { -EOF - map { print " { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}}; - print <{name}_index(lua_State *L) -{ - const char *idx = luaL_checkstring(L, 2); - - switch (mlua_which_token(idx, -1)) { -EOF - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - my $call = $t{type}->{push} || '$$'; - - $call =~ s/\$L/L/; - $call =~ s/\$\$/$pkg->{cname}.$p->{name}/; - - my $tok = $p->{name}; - $tok =~ tr/a-z/A-Z/; - - if ($t{type}->{kind} eq 'b') { - $call = "lua_pushboolean(L, $call)"; - } - - if ($t{type}->{kind} eq 'i') { - $call = "lua_pushinteger(L, $call)"; - } - - if ($t{type}->{kind} eq 's') { - $call = "lua_pushstring(L, $call)"; - } - - put_line($p, 0); - print " case LTK_$tok:\n"; - printf " $call;\n"; - print " return 1;\n"; - } - -print <{name}_newindex(lua_State *L) -{ - const char *idx = luaL_checkstring(L, 2); - - switch (mlua_which_token(idx, -1)) { -EOF - - foreach (@{$pkg->{props}}) { - my $p = $pkg->{members}{$_}; - my %t = find_type($p, $p->{type}); - - next if ($t{const}); - - my $tok = $p->{name}; - my $var = $pkg->{cname}.".".$p->{name}; - my $check = $t{type}->{check}; - $tok =~ tr/a-z/A-Z/; - $check =~ s/\$L/L/; - $check =~ s/\$\$/3/; - - put_line($p, 0); - print " case LTK_$tok: \n"; - if ($t{type}->{dtor}) { - my $dtor = $t{type}->{dtor}; - $dtor =~ s/\$L/L/; - $dtor =~ s/\$\$/\&$var/; - print " $dtor;\n"; - } - if ($t{type}->{ctor}) { - my $ctor = $t{type}->{ctor}; - $ctor =~ s/\$L/L/; - $ctor =~ s/\$\$/$check/; - $check = $ctor; - } - print " $var = $check;\n"; - print " return 1;\n"; - } - -print <{name}(lua_State *L) -{ - int mt, methods; - - $pkg->{cname}_init(); - - /* create methods table, add it the the table of globals */ - luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0); - methods = lua_gettop(L); - - /* create metatable for $pkg->{name}, add it to the registry */ - luaL_newmetatable(L, "$pkg->{name}"); - mt = lua_gettop(L); - - lua_pushliteral(L, "__index"); - lua_pushvalue(L, mt); /* upvalue 1 */ - lua_pushvalue(L, methods); /* upvalue 2 */ - lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2); - lua_rawset(L, mt); /* set mt.__index */ - - lua_pushliteral(L, "__newindex"); - lua_newtable(L); /* for new members */ - lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1); - lua_rawset(L, mt); /* set mt.__newindex */ - - lua_pushliteral(L, "__metatable"); - lua_pushvalue(L, methods); /* dup methods table */ - lua_rawset(L, mt); /* hide metatable */ - - lua_setmetatable(L, methods); - - lua_pop(L, 1); /* drop mt */ - return 1; /* return methods */ -} - -EOF -} - -sub dump_package_short($) { - my $pkg = shift; - my $upp = $pkg->{name}; - $upp =~ tr/a-z/A-Z/; - - print <{name}(lua_State *L); - -#endif /* MUTT_LUA_${upp}_H */ -EOF -} - -#}}} - -sub do_c($) { - my %src = stream_open(shift); - my $resync = 1; - - while (stream_getline(\%src)) { - if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) { - parse_type(\%src, $1); - $resync = 1; - } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) { - dump_package_full(parse_package(\%src, $1), 1); - $resync = 1; - } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) { - dump_package_full(parse_package(\%src, $1), 0); - $resync = 1; - } elsif (/^\s*(\@\w*)/) { - fatal(\%src, "syntax error: unknown directive `$1'"); - } else { - next if ($resync && /^\s+$/); - if ($resync) { - put_line(\%src, 0); - $resync = 0; - } - print; - } - } - - stream_close(\%src); -} - -sub do_h($) { - my %src = stream_open(shift); - my $resync = 1; - - while (stream_getline(\%src)) { - if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) { - parse_type(\%src, $1); - } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) { - dump_package_short(parse_package(\%src, $1)); - } elsif (/^\s*(\@\w*)/) { - fatal(\%src, "syntax error: unknown directive `$1'"); - } - } - - stream_close(\%src); -} - -if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) { - print <