mirror of
https://github.com/xcat2/xcat-dep.git
synced 2025-02-20 12:30:04 +00:00
469 lines
9.3 KiB
Perl
469 lines
9.3 KiB
Perl
package Gen;
|
|
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(lookup Q process_DATA_chunk
|
|
process_functions process_variables process_constants
|
|
process_typedefs);
|
|
|
|
my $list_fun = "gen/list.fun";
|
|
my $list_var = "gen/list.var";
|
|
my $list_con = "gen/list.con";
|
|
my $list_typ = "gen/list.typ";
|
|
|
|
###
|
|
## Declaration entries
|
|
#
|
|
my $MAP = {
|
|
'attr_t' => {
|
|
'DECL_NOR' => '(attr_t)SvIV($A)',
|
|
'RETN_NOR' => 'sv_setiv($A, (IV)$N)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '0',
|
|
'RETN_OUT' => 'sv_setiv($A, (IV)$N);',
|
|
'TEST_OUT' => 'LINES',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'bool' => {
|
|
'DECL_NOR' => '(int)SvIV($A)',
|
|
'RETN_NOR' => 'sv_setiv($A, (IV)$N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'char' => {
|
|
'RETN_NOR' => 'sv_setpvn($A, (char *)&$N, 1)',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'char *' => {
|
|
'DECL_NOR' => '(char *)SvPV($A,PL_na)',
|
|
'RETN_NOR' => 'sv_setpv((SV*)$A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '(char *)sv_grow($A, $B)',
|
|
'RETN_OUT' => 'c_setchar($A, $N)',
|
|
'TEST_OUT' => '0',
|
|
'DECL_OPT' => '$A != &PL_sv_undef ? (char *)SvPV($A,PL_na) : NULL',
|
|
'TEST_OPT' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'chtype' => {
|
|
'DECL_NOR' => 'c_sv2chtype($A)',
|
|
'RETN_NOR' => 'c_chtype2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'chtype *' => {
|
|
'DECL_NOR' => '(chtype *)SvPV($A,PL_na)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '(chtype *)sv_grow($A, ($B)*sizeof(chtype))',
|
|
'RETN_OUT' => 'c_setchtype($A, $N)',
|
|
'TEST_OUT' => '0',
|
|
},
|
|
|
|
'FIELD *' => {
|
|
'DECL_NOR' => 'c_sv2field($A, $B)',
|
|
'RETN_NOR' => 'c_field2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'FIELD **' => {
|
|
'DECL_NOR' => '(FIELD **)SvPV($A,PL_na)',
|
|
'RETN_NOR' => 'sv_setpv((SV*)$A, (char *)$N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => '0',
|
|
},
|
|
|
|
'FILE *' => {
|
|
'DECL_NOR' => 'IoIFP(sv_2io($A))',
|
|
'TEST_NOR' => '0',
|
|
},
|
|
|
|
'FORM *' => {
|
|
'DECL_NOR' => 'c_sv2form($A, $B)',
|
|
'RETN_NOR' => 'c_form2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'int' => {
|
|
'DECL_NOR' => '(int)SvIV($A)',
|
|
'RETN_NOR' => 'sv_setiv($A, (IV)$N)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '0',
|
|
'RETN_OUT' => 'sv_setiv($A, (IV)$N);',
|
|
'TEST_OUT' => 'LINES',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'ITEM *' => {
|
|
'DECL_NOR' => 'c_sv2item($A, $B)',
|
|
'RETN_NOR' => 'c_item2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'ITEM **' => {
|
|
'DECL_NOR' => '(ITEM **)SvPV($A,PL_na)',
|
|
'RETN_NOR' => 'sv_setpv((SV*)$A, (char *)$N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => '0',
|
|
},
|
|
|
|
'MENU *' => {
|
|
'DECL_NOR' => 'c_sv2menu($A, $B)',
|
|
'RETN_NOR' => 'c_menu2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'MEVENT *' => {
|
|
'DECL_NOR' => '(MEVENT *)SvPV($A,PL_na)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '(MEVENT *)sv_grow($A, 2 * sizeof(MEVENT))',
|
|
'RETN_OUT' => 'c_setmevent($A, $N)',
|
|
'TEST_OUT' => '0',
|
|
},
|
|
|
|
'mmask_t' => {
|
|
'DECL_NOR' => '(mmask_t)SvIV($A)',
|
|
'RETN_NOR' => 'sv_setiv($A, (IV)$N)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '0',
|
|
'RETN_OUT' => 'sv_setiv($A, (IV)$N);',
|
|
'TEST_OUT' => 'LINES',
|
|
'RETN_NUL' => 'ERR',
|
|
},
|
|
|
|
'PANEL *' => {
|
|
'DECL_NOR' => 'c_sv2panel($A, $B)',
|
|
'RETN_NOR' => 'c_panel2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OPT' => '$A != &PL_sv_undef ? c_sv2panel($A, $B) : NULL',
|
|
'TEST_OPT' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'SCREEN *' => {
|
|
'DECL_NOR' => 'c_sv2screen($A, $B)',
|
|
'RETN_NOR' => 'c_screen2sv($A, $N)',
|
|
'TEST_NOR' => '0',
|
|
'RETN_NUL' => 'NULL',
|
|
},
|
|
|
|
'short' => {
|
|
'DECL_NOR' => '(short)SvIV($A)',
|
|
'TEST_NOR' => '0',
|
|
'DECL_OUT' => '0',
|
|
'RETN_OUT' => 'sv_setiv($A, (IV)$N);',
|
|
'TEST_OUT' => 'LINES',
|
|
},
|
|
|
|
'void' => {
|
|
'RETN_NOR' => 'not gonna happen',
|
|
'RETN_NUL' => 'not gonna happen',
|
|
},
|
|
|
|
'void *' => {
|
|
'DECL_NOR' => '0',
|
|
'TEST_NOR' => '0',
|
|
},
|
|
|
|
'WINDOW *' => {
|
|
'DECL_NOR' => 'c_sv2window($A, $B)',
|
|
'RETN_NOR' => 'c_window2sv($A, $N)',
|
|
'TEST_NOR' => 'stdscr',
|
|
'RETN_NUL' => 'NULL',
|
|
}
|
|
};
|
|
|
|
## Allow us to put some quoting around here documents to make them stand out
|
|
#
|
|
sub Q {
|
|
my $text = shift;
|
|
|
|
$text =~ s/^#{16}\n//mg;
|
|
$text =~ s/^#\t?//mg;
|
|
$text;
|
|
}
|
|
|
|
## Print a chunk of data, 'til we hit PAUSE
|
|
#
|
|
sub process_DATA_chunk {
|
|
my $proc = shift;
|
|
my ($pkg) = (caller)[0];
|
|
|
|
*DATA = *{"${pkg}::DATA"};
|
|
|
|
while (<DATA>) {
|
|
last if /^PAUSE$/;
|
|
|
|
&{$proc}($_);
|
|
}
|
|
}
|
|
|
|
my $pattern = '^\s* (?:const \s+)? ( (?:[{<|] [^}>|]+ [}>|])* )' .
|
|
'\s* (\S+ (?: \s+ \*+)?) \s* ( [{<|] \w+ [}>|] )* \s* (\w+)';
|
|
|
|
|
|
sub process_functions {
|
|
my $proc = shift;
|
|
my $numf = 1;
|
|
|
|
open INF, $list_fun or die "Can't open $list_fun: $!\n";
|
|
|
|
FCN:
|
|
while (<INF>) {
|
|
next if /^!/;
|
|
|
|
while (s/\\\n//) {
|
|
$_ .= <INF>;
|
|
die "$list_fun: Unterminated backslash\n" if eof;
|
|
}
|
|
|
|
my $fun = {
|
|
LINE => $_,
|
|
DOIT => 0
|
|
};
|
|
|
|
if (/^> (.+) \( (.+) \) ; /x) {
|
|
my $lhs = $1;
|
|
my $args = $2;
|
|
|
|
unless ($lhs =~ /$pattern/xo) {
|
|
warn "$lhs($args): bad function prototype\n";
|
|
next FCN;
|
|
}
|
|
|
|
$fun->{SPEC} = $1;
|
|
$fun->{DECL} = $2;
|
|
$fun->{UNI} = $3;
|
|
$fun->{NAME} = $4;
|
|
$fun->{DOIT} = 1;
|
|
$fun->{NUM} = $numf++;
|
|
$fun->{ARGV} = [ ];
|
|
|
|
$fun->{SPEC} = { map { uc($_) => 1 } $fun->{SPEC} =~ /{(.+?)}/g };
|
|
$fun->{W} = $fun->{UNI} && $fun->{UNI} =~ /[{|]/ ? 'w' : '';
|
|
my $argc = 0;
|
|
foreach my $entry (split /\s*,\s*/, $args) {
|
|
next if $entry eq 'void';
|
|
|
|
unless ($entry =~ /$pattern/xo) {
|
|
warn "$fun->{NAME}( $entry ): bad arg prototype\n";
|
|
next FCN;
|
|
}
|
|
|
|
my $arg = $fun->{ARGV}[$argc] = { };
|
|
$arg->{SPEC} = $1;
|
|
$arg->{DECL} = $2;
|
|
$arg->{NAME} = $4;
|
|
|
|
$arg->{SPEC} = { map { /=/ ? (uc($`) => $') : (uc($_) => 1) }
|
|
$arg->{SPEC} =~ /{(.+?(?:=.+?)?)}/g };
|
|
|
|
$arg->{MAP} = { };
|
|
$arg->{NUM} = $argc++;
|
|
|
|
my $typ = 'NOR';
|
|
if ($arg->{SPEC}{OUT}) { $typ = 'OUT' }
|
|
elsif ($arg->{SPEC}{OPT}) { $typ = 'OPT' }
|
|
|
|
my $decl = $MAP->{$arg->{DECL}}{"DECL_$typ"};
|
|
if (not defined $decl) {
|
|
warn "$fun->{NAME}( $arg->{DECL} $arg->{NAME} ): " .
|
|
"no map rewrite for DECL_$typ\n";
|
|
next FCN;
|
|
}
|
|
$arg->{M_DECL} = $decl;
|
|
|
|
if ($typ eq 'OUT') {
|
|
my $retn = $MAP->{$arg->{DECL}}{"RETN_$typ"};
|
|
if (not defined $retn) {
|
|
warn "$fun->{NAME}( $arg->{DECL} $arg->{NAME} ): " .
|
|
"no map rewrite for RETN_$typ\n";
|
|
next FCN;
|
|
}
|
|
$arg->{M_RETN} = $retn;
|
|
}
|
|
|
|
my $test = $MAP->{$arg->{DECL}}{"TEST_$typ"};
|
|
if (not defined $test) {
|
|
warn "$fun->{NAME}( $arg->{DECL} $arg->{NAME} ): " .
|
|
"no map rewrite for TEST_$typ\n";
|
|
next FCN;
|
|
}
|
|
$arg->{M_TEST} = $test;
|
|
}
|
|
|
|
my $retn = $MAP->{$fun->{DECL}}{RETN_NOR};
|
|
if (not defined $retn) {
|
|
warn "$fun->{DECL} $fun->{NAME}( ): " .
|
|
"no map rewrite for RETN_NOR\n";
|
|
next FCN;
|
|
}
|
|
|
|
my $null = $MAP->{$fun->{DECL}}{RETN_NUL};
|
|
if (not defined $null) {
|
|
warn "$fun->{DECL} $fun->{NAME}( ): " .
|
|
"no map rewrite for RETN_NUL\n";
|
|
next FCN;
|
|
}
|
|
|
|
$fun->{M_RETN} = $retn;
|
|
$fun->{M_NULL} = $null;
|
|
$fun->{ARGC} = $argc;
|
|
}
|
|
&{$proc}($fun);
|
|
}
|
|
|
|
close INF;
|
|
}
|
|
|
|
sub process_variables {
|
|
my $proc = shift;
|
|
my $numv = 1;
|
|
|
|
open INV, $list_var or die "Can't open $list_var: $!\n";
|
|
|
|
while (<INV>) {
|
|
next if /^!/;
|
|
|
|
while (s/\\\n//) {
|
|
$_ .= <INV>;
|
|
die "$list_var: Unterminated backslash\n" if eof;
|
|
}
|
|
|
|
my $var = {
|
|
LINE => $_,
|
|
DOIT => 0
|
|
};
|
|
|
|
if (/^> (.+) ; /x) {
|
|
my $lhs = $1;
|
|
|
|
unless ($lhs =~ /$pattern/xo) {
|
|
warn "$lhs: bad variable prototype\n";
|
|
next;
|
|
}
|
|
|
|
$var->{SPEC} = $1;
|
|
$var->{DECL} = $2;
|
|
$var->{NAME} = $4;
|
|
$var->{DOIT} = 1;
|
|
$var->{NUM} = $numv++;
|
|
|
|
$var->{SPEC} = { map { uc($_) => 1 } $var->{SPEC} =~ /{(.+?)}/g };
|
|
|
|
my $decl = $MAP->{$var->{DECL}}{DECL_NOR};
|
|
if (not defined $decl) {
|
|
warn "$var->{DECL} $var->{NAME}: " .
|
|
"no map rewrite for DECL_$typ\n";
|
|
next;
|
|
}
|
|
|
|
my $retn = $MAP->{$var->{DECL}}{RETN_NOR};
|
|
if (not defined $retn) {
|
|
warn "$var->{DECL} $var->{NAME}: " .
|
|
"no map rewrite for RETN_NOR\n";
|
|
next;
|
|
}
|
|
|
|
$var->{M_DECL} = $decl;
|
|
$var->{M_RETN} = $retn;
|
|
}
|
|
&{$proc}($var);
|
|
}
|
|
|
|
close INV;
|
|
}
|
|
|
|
sub process_constants {
|
|
my $proc = shift;
|
|
my $numc = 1;
|
|
|
|
open INC, $list_con or die "Can't open $list_con: $!\n";
|
|
|
|
while (<INC>) {
|
|
next if /^!/;
|
|
|
|
while (s/\\\n//) {
|
|
$_ .= <INC>;
|
|
die "$list_con: Unterminated backslash\n" if eof;
|
|
}
|
|
|
|
my $con = {
|
|
LINE => $_,
|
|
DOIT => 0
|
|
};
|
|
|
|
if (/^> (.+) ; /x) {
|
|
my $lhs = $1;
|
|
|
|
unless ($lhs =~ /$pattern/xo) {
|
|
warn "$lhs: bad variable prototype\n";
|
|
next;
|
|
}
|
|
|
|
$con->{SPEC} = $1;
|
|
$con->{DECL} = $2;
|
|
$con->{NAME} = $4;
|
|
$con->{DOIT} = 1;
|
|
$con->{NUM} = $numc++;
|
|
|
|
$con->{SPEC} = { map { uc($_) => 1 } $con->{SPEC} =~ /{(.+?)}/g };
|
|
|
|
}
|
|
&{$proc}($con);
|
|
}
|
|
|
|
close INC;
|
|
}
|
|
|
|
sub process_typedefs {
|
|
my $proc = shift;
|
|
my $numt = 1;
|
|
|
|
open INT, $list_typ or die "Can't open $list_typ: $!\n";
|
|
|
|
while (<INT>) {
|
|
next if /^!/;
|
|
|
|
while (s/\\\n//) {
|
|
$_ .= <INT>;
|
|
die "$list_typ: Unterminated backslash\n" if eof;
|
|
}
|
|
|
|
my $typ = {
|
|
LINE => $_,
|
|
DOIT => 0
|
|
};
|
|
|
|
if (/^> \s+ (.+) /x) {
|
|
my $lhs = $1;
|
|
|
|
unless ($lhs =~ /$pattern/xo) {
|
|
warn "$lhs: bad typedef prototype\n";
|
|
next;
|
|
}
|
|
|
|
$typ->{SPEC} = $1;
|
|
$typ->{DECL} = $2;
|
|
$typ->{NAME} = $4;
|
|
$typ->{DOIT} = 1;
|
|
$typ->{NUM} = $numt++;
|
|
|
|
$typ->{SPEC} = { map { uc($_) => 1 } $typ->{SPEC} =~ /{(.+?)}/g };
|
|
|
|
}
|
|
&{$proc}($typ);
|
|
}
|
|
|
|
close INT;
|
|
}
|
|
|
|
1;
|