pmarquess at bfsec
Aug 21, 1995, 4:55 PM
Post #1 of 1
(328 views)
Permalink
|
This patch upgrades xsubpp 1.91 to 1.92
It consists mostly of minor tidy up's to make xsubpp more robust.
99% of these are courtesy of Hallvard B Furuseth. Thanks Hallvard.
See the MODIFICATION HISTORY section of the in-line pod for full
details.
The only addition to the existing functionality is the new ALIAS:
keyword as discussed on the list a few weeks ago.
Tim, as it was you who wanted the alias stuff, could you give it a go
and see if it does everything you need.
I have applied this patch to 2.x xsubpp as well, but I'll hold off from
posting it till I get some time to track down the problems with tie.
Paul
*** xsubpp-1.91 Wed Jul 12 14:57:00 1995
--- xsubpp Mon Aug 14 16:49:59 1995
***************
*** 205,210 ****
--- 205,267 ----
No longer needs space in front of input variables.
Cleaned up and rearranged the code. Some bugfixes and minor changes.
+ INIT: is just like CODE:, except it has no side effects - while CODE:
+ prevents RETVAL computation.
+
+ PREINIT: is the same, but is used before - or interleaved with - the
+ input variables. INPUT: starts input variables that follow PREINIT:.
+
+ =head2 1.92
+
+ Changes by Hallvard B Furuseth <h.b.furuseth [at] usit> and Paul
+ Marquess <pmarquess [at] bfsec>, 14 August 1995.
+
+ =over 5
+
+ =item 1.
+
+ Previously whenever a duplicate function was detected multiple newXS
+ calls were generated for it in the boot function. This is no longer the
+ case.
+
+ =item 2.
+
+ Addition of ALIAS: keyword. Format is
+
+ ALIAS: alias = value alias = value
+ alias = value
+
+ =item 3.
+
+ reject `INPUT: &var' without type. This was taken as type `&'.
+ Accept whitespace after `&'.
+
+ =item 4.
+
+ Catch duplicate RETVAL output args.
+
+ =item 5.
+
+ Catch initialization `var==3', `var=' would become the varname.
+
+ =item 6.
+
+ Don't make `usage' error in functions with only optional args, it would
+ never be used.
+
+ =item 7.
+
+ Catch this bug:
+
+ void
+ pp_foo(x)
+ # missing CASE:
+ INPUT: ...
+
+ CASE: ...
+
+ =back
+
=head1 SEE ALSO
perl(1), perlapi(1)
***************
*** 212,224 ****
=cut
# Global Constants
! $XSUBPP_version = "1.91";
require 5.001;
$usage = "Usage: xsubpp [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n";
$except = "";
! SWITCH: while ($ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = shift, next SWITCH if $flag eq 's';
--- 269,281 ----
=cut
# Global Constants
! $XSUBPP_version = "1.92";
require 5.001;
$usage = "Usage: xsubpp [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n";
$except = "";
! SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = shift, next SWITCH if $flag eq 's';
***************
*** 314,320 ****
$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
# Match an XS keyword
! $BLOCK_re= "\\s*(BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
--- 371,377 ----
$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
# Match an XS keyword
! $BLOCK_re= "\\s*(BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|ALIAS|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
***************
*** 355,364 ****
# check for optional initialisation code
my $var_init = '' ;
$var_init = $1 if s/\s*(=.*)$//s ;
! my ($var_type, $var_addr, $var_name) = /^(.*?\S)\s*(\&?)\b(\w+)$/s
or blurt("Error: invalid argument declaration '$line'"), next;
- $var_type =~ s/\s+/ /g;
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
--- 412,422 ----
# check for optional initialisation code
my $var_init = '' ;
$var_init = $1 if s/\s*(=.*)$//s ;
+ $var_init =~ s/"/\\"/g;
! s/\s+/ /g;
! my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
or blurt("Error: invalid argument declaration '$line'"), next;
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
***************
*** 389,396 ****
sub OUTPUT_handler {
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
! TrimWhitespace($_) ;
! my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
if (!$gotRETVAL and $outarg eq 'RETVAL') {
# deal with RETVAL last
$RETVAL_code = $outcode ;
--- 447,455 ----
sub OUTPUT_handler {
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
! my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
! blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
! if $outargs{$outarg} ++ ;
if (!$gotRETVAL and $outarg eq 'RETVAL') {
# deal with RETVAL last
$RETVAL_code = $outcode ;
***************
*** 397,404 ****
$gotRETVAL = 1 ;
next ;
}
- blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
- if $outargs{$outarg} ++ ;
blurt ("Error: OUTPUT $outarg not an argument"), next
unless defined($args_match{$outarg});
blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
--- 456,461 ----
***************
*** 412,417 ****
--- 469,516 ----
}
}
+ sub GetAliases
+ {
+ my ($line) = @_ ;
+ my ($orig) = $line ;
+ my ($alias) ;
+ my ($value) ;
+
+ # Parse alias definitions
+ # format is
+ # alias = value alias = value ...
+
+ while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
+ $alias = $1 ;
+ $orig_alias = $alias ;
+ $value = $2 ;
+
+ # check for optional package definition in the alias
+ $alias = $Packprefix . $alias if $alias !~ /::/ ;
+
+ # check for duplicate alias name & duplicate value
+ Warn("Warning: Ignoring duplicate alias '$orig_alias'")
+ if defined $XsubAliases{$pname}{$alias} ;
+
+ Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
+ if $XsubAliasValues{$pname}{$value} ;
+
+ $XsubAliases{$pname}{$alias} = $value ;
+ $XsubAliasValues{$pname}{$value} = $orig_alias ;
+ }
+
+ blurt("Error: Cannot parse ALIAS definitions from '$orig'")
+ if $line ;
+ }
+
+ sub ALIAS_handler
+ {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ GetAliases($_) if $_ ;
+ }
+ }
sub check_cpp {
my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
***************
*** 547,568 ****
$func_header = shift(@line);
blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
! unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
! ($func_name, $orig_args) = ($1, $2) ;
! if ($func_name =~ /(.*)::(.*)/) {
! $class = $1;
! $func_name = $2;
! }
($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
# Check for duplicate function definition
! Warn("Warning: duplicate function definition '$func_name' detected")
! if defined $Func_name{"${Packid}_$func_name"} ;
$Func_name{"${Packid}_$func_name"} ++ ;
- push(@Func_name, "${Packid}_$func_name");
- push(@Func_pname, $pname);
@args = split(/\s*,\s*/, $orig_args);
if (defined($class)) {
my $arg0 = (defined($static) ? "CLASS" : "THIS");
--- 646,666 ----
$func_header = shift(@line);
blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
! unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
! ($class, $func_name, $orig_args) = ($1, $2, $3) ;
($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
# Check for duplicate function definition
! if (defined $Func_name{"${Packid}_$func_name"} ) {
! Warn("Warning: duplicate function definition '$func_name' detected")
! }
! else {
! push(@Func_name, "${Packid}_$func_name");
! push(@Func_pname, $pname);
! }
$Func_name{"${Packid}_$func_name"} ++ ;
@args = split(/\s*,\s*/, $orig_args);
if (defined($class)) {
my $arg0 = (defined($static) ? "CLASS" : "THIS");
***************
*** 580,586 ****
last;
}
}
! if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
$min_args--;
$args[$i] = $1;
$defaults{$args[$i]} = $2;
--- 678,684 ----
last;
}
}
! if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
$min_args--;
$args[$i] = $1;
$defaults{$args[$i]} = $2;
***************
*** 595,600 ****
--- 693,699 ----
@args_match{@args} = 1..@args;
$PPCODE = grep(/^\s*PPCODE\s*:/, @line);
+ $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
# print function header
print Q<<"EOF";
***************
*** 602,609 ****
#[[
# dXSARGS;
EOF
if ($elipsis) {
! $cond = qq(items < $min_args);
}
elsif ($min_args == $num_args) {
$cond = qq(items != $min_args);
--- 701,711 ----
#[[
# dXSARGS;
EOF
+ print Q<<"EOF" if $ALIAS ;
+ # dXSI32;
+ EOF
if ($elipsis) {
! $cond = ($min_args ? qq(items < $min_args) : 0);
}
elsif ($min_args == $num_args) {
$cond = qq(items != $min_args);
***************
*** 617,624 ****
# *errbuf = '\0';
EOF
! print Q<<"EOF";
# if ($cond)
# croak("Usage: $pname($orig_args)");
EOF
--- 719,732 ----
# *errbuf = '\0';
EOF
! if ($ALIAS)
! { print Q<<"EOF" if $cond }
# if ($cond)
+ # croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
+ EOF
+ else
+ { print Q<<"EOF" if $cond }
+ # if ($cond)
# croak("Usage: $pname($orig_args)");
EOF
***************
*** 676,682 ****
$var_types{"RETVAL"} = $ret_type;
}
print $deferred;
! &print_section while check_keyword("INIT");
if (check_keyword("PPCODE")) {
&print_section;
death ("PPCODE must be last thing") if @line;
--- 784,798 ----
$var_types{"RETVAL"} = $ret_type;
}
print $deferred;
! while ($kwd = check_keyword("INIT|ALIAS")) {
! if ($kwd eq 'INIT') {
! &print_section
! }
! else {
! ALIAS_handler
! }
! }
!
if (check_keyword("PPCODE")) {
&print_section;
death ("PPCODE must be last thing") if @line;
***************
*** 734,739 ****
--- 850,857 ----
# ENDHANDLERS
EOF
if (check_keyword("CASE")) {
+ blurt ("Error: No `CASE:' at top of function")
+ unless $condnum;
$_ = "CASE: $_"; # Restore CASE: label
next;
}
***************
*** 766,774 ****
#
EOF
for (@Func_name) {
$pname = shift(@Func_pname);
! print " newXS(\"$pname\", XS_$_, file);\n";
}
if (@BootCode)
--- 884,910 ----
#
EOF
+ print Q<<"EOF" if defined %XsubAliases ;
+ # SV * cv ;
+ #
+ EOF
+
for (@Func_name) {
$pname = shift(@Func_pname);
!
! if ($XsubAliases{$pname}) {
! $XsubAliases{$pname}{$pname} = 0
! unless defined $XsubAliases{$pname}{$pname} ;
! while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
! print Q<<"EOF" ;
! # cv = newXS(\"$name\", XS_$_, file);
! # XSANY.any_i32 = $value ;
! EOF
! }
! }
! else {
! print " newXS(\"$pname\", XS_$_, file);\n";
! }
}
if (@BootCode)
***************
*** 791,796 ****
--- 927,933 ----
local($type, $num, $init) = @_;
local($arg) = "ST(" . ($num - 1) . ")";
+ warn "output_init: ($type, $num, $init) arg = $arg \n" ;
eval qq/print " $init\\\n"/;
}
|
