make_targetable
map_type
standard_XS_defs
+ assign_func_args
+ analyze_preprocessor_statements
+ set_cond
+ Warn
+ blurt
+ death
+ check_conditional_preprocessor_statements
);
our @ISA = qw(Exporter);
# them into $self led to build problems. In most cases, strings being
# 'eval'-ed contain the variables' names hard-coded.
our (
- $FH, $Package, $func_name, $Full_func_name, $Packid, $pname, $ALIAS,
+ $FH, $Package, $func_name, $Full_func_name, $pname, $ALIAS,
);
-our $self = {};
+our $self = bless {} => __PACKAGE__;
sub process_file {
# Establish set of global symbols with max length 28, since xsubpp
# will later add the 'XS_' prefix.
require ExtUtils::XSSymSet;
- $SymSet = new ExtUtils::XSSymSet 28;
+ $SymSet = ExtUtils::XSSymSet->new(28);
}
@{ $self->{XSStack} } = ({type => 'none'});
$self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
}
# Really, we shouldn't have to chdir() or select() in the first
- # place. For now, just save & restore.
+ # place. For now, just save and restore.
my $orig_cwd = cwd();
my $orig_fh = select();
select $args{output};
}
- (
- $self->{type_kind},
- $self->{proto_letter},
- $self->{input_expr},
- $self->{output_expr},
- ) = process_typemaps( $args{typemap}, $pwd );
-
- foreach my $value (values %{ $self->{input_expr} }) {
- $value =~ s/;*\s+\z//;
- # Move C pre-processor instructions to column 1 to be strictly ANSI
- # conformant. Some pre-processors are fussy about this.
- $value =~ s/^\s+#/#/mg;
- }
- foreach my $value (values %{ $self->{output_expr} }) {
- # And again.
- $value =~ s/^\s+#/#/mg;
- }
-
- my %targetable = make_targetable($self->{output_expr});
+ $self->{typemap} = process_typemaps( $args{typemap}, $pwd );
my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
# Match an XS keyword
$self->{BLOCK_re} = '\s*(' .
- join('|' => @ExtUtils::ParseXS::Constants::keywords) .
+ join('|' => @ExtUtils::ParseXS::Constants::XSKeywords) .
"|$END)\\s*:";
our ($C_group_rex, $C_arg);
$self->{lastline} = $_;
$self->{lastline_no} = $.;
- my ($xsreturn, );
my $BootCode_ref = [];
- my $outlist_ref = [];
my $XSS_work_idx = 0;
my $cpp_next_tmp = 'XSubPPtmpAAAA';
PARAGRAPH:
- while (fetch_para()) {
+ while ($self->fetch_para()) {
+ my $outlist_ref = [];
# Print initial preprocessor statements and blank lines
while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) {
my $ln = shift(@{ $self->{line} });
print $ln, "\n";
next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+ my $statement = $+;
( $self, $XSS_work_idx, $BootCode_ref ) =
- print_preprocessor_statements( $self, $XSS_work_idx, $BootCode_ref );
+ analyze_preprocessor_statements(
+ $self, $statement, $XSS_work_idx, $BootCode_ref
+ );
}
next PARAGRAPH unless @{ $self->{line} };
$self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++;
}
- death ("Code is not inside a function"
- ." (maybe last function was ended by a blank line "
- ." followed by a statement on column one?)")
+ death( $self,
+ "Code is not inside a function"
+ ." (maybe last function was ended by a blank line "
+ ." followed by a statement on column one?)")
if $self->{line}->[0] =~ /^\s/;
- my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
- my (@fake_INPUT_pre); # For length(s) generated variables
- my (@fake_INPUT);
-
# initialize info arrays
- undef(%{ $self->{args_match} });
- undef(%{ $self->{var_types} });
- undef(%{ $self->{defaults} });
- undef(%{ $self->{arg_list} });
- undef(@{ $self->{proto_arg} });
- undef($self->{processing_arg_with_types});
- undef(%{ $self->{argtype_seen} });
- undef(@{ $outlist_ref });
- undef(%{ $self->{in_out} });
- undef(%{ $self->{lengthof} });
- undef($self->{proto_in_this_xsub});
- undef($self->{scope_in_this_xsub});
- undef($self->{interface});
- $self->{interface_macro} = 'XSINTERFACE_FUNC';
- $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
- $self->{ProtoThisXSUB} = $self->{WantPrototypes};
- $self->{ScopeThisXSUB} = 0;
- $xsreturn = 0;
+ foreach my $member (qw(args_match var_types defaults arg_list
+ argtype_seen in_out lengthof))
+ {
+ $self->{$member} = {};
+ }
+ $self->{proto_arg} = [];
+ $self->{processing_arg_with_types} = undef;
+ $self->{proto_in_this_xsub} = undef;
+ $self->{scope_in_this_xsub} = undef;
+ $self->{interface} = undef;
+ $self->{interface_macro} = 'XSINTERFACE_FUNC';
+ $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
+ $self->{ProtoThisXSUB} = $self->{WantPrototypes};
+ $self->{ScopeThisXSUB} = 0;
+
+ my $xsreturn = 0;
$_ = shift(@{ $self->{line} });
- while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
- no strict 'refs';
- &{"${kwd}_handler"}();
- use strict 'refs';
+ while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
+ my $method = $kwd . "_handler";
+ $self->$method($_);
next PARAGRAPH unless @{ $self->{line} };
$_ = shift(@{ $self->{line} });
}
- if (check_keyword("BOOT")) {
- check_cpp($self);
+ if ($self->check_keyword("BOOT")) {
+ check_conditional_preprocessor_statements($self);
push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"$self->{filepathname}\"")
if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/;
push (@{ $BootCode_ref }, @{ $self->{line} }, "");
# extract return type, function name and arguments
($self->{ret_type}) = tidy_type($_);
- $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
+ my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
# Allow one-line ANSI-like declaration
unshift @{ $self->{line} }, $2
and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
# a function definition needs at least 2 lines
- blurt ("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
+ blurt( $self, "Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
unless @{ $self->{line} };
- $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
- $static = 1 if $self->{ret_type} =~ s/^static\s+//;
+ my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
+ my $static = 1 if $self->{ret_type} =~ s/^static\s+//;
my $func_header = shift(@{ $self->{line} });
- blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
+ blurt( $self, "Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
- my $orig_args;
+ my ($class, $orig_args);
($class, $func_name, $orig_args) = ($1, $2, $3);
$class = "$4 $class" if $4;
($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/;
my $clean_func_name;
($clean_func_name = $func_name) =~ s/^$self->{Prefix}//;
- $Full_func_name = "${Packid}_$clean_func_name";
+ $Full_func_name = "$self->{Packid}_$clean_func_name";
if ($Is_VMS) {
$Full_func_name = $SymSet->addsym($Full_func_name);
}
# Check for duplicate function definition
for my $tmp (@{ $self->{XSStack} }) {
next unless defined $tmp->{functions}{$Full_func_name};
- Warn("Warning: duplicate function definition '$clean_func_name' detected");
+ Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected");
last;
}
$self->{XSStack}->[$XSS_work_idx]{functions}{$Full_func_name}++;
$orig_args =~ s/\\\s*/ /g; # process line continuations
my @args;
+ my (@fake_INPUT_pre); # For length(s) generated variables
+ my (@fake_INPUT);
my $only_C_inlist_ref = {}; # Not in the signature of Perl function
if ($self->{argtypes} and $orig_args =~ /\S/) {
my $args = "$orig_args ,";
}
else {
@args = split(/\s*,\s*/, $orig_args);
- Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
+ Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split");
}
}
else {
my @args_num = ();
my $num_args = 0;
my $report_args = '';
+ my $ellipsis;
foreach my $i (0 .. $#args) {
if ($args[$i] =~ s/\.\.\.//) {
$ellipsis = 1;
my $min_args = $num_args - $extra_args;
$report_args =~ s/"/\\"/g;
$report_args =~ s/^,\s+//;
- my @func_args = @args;
- shift @func_args if defined($class);
-
- for (@func_args) {
- s/^/&/ if $self->{in_out}->{$_};
- }
- $self->{func_args} = join(", ", @func_args);
+ $self->{func_args} = assign_func_args($self, \@args, $class);
@{ $self->{args_match} }{@args} = @args_num;
my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} });
my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} });
# Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
- # to set explicit return values.
+ # to set explicit return values.
my $EXPLICIT_RETURN = ($CODE &&
("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
print Q(<<"EOF") if $INTERFACE;
# dXSFUNCTION($self->{ret_type});
EOF
- if ($ellipsis) {
- $self->{cond} = ($min_args ? qq(items < $min_args) : 0);
- }
- elsif ($min_args == $num_args) {
- $self->{cond} = qq(items != $min_args);
- }
- else {
- $self->{cond} = qq(items < $min_args || items > $num_args);
- }
+
+ $self->{cond} = set_cond($ellipsis, $min_args, $num_args);
print Q(<<"EOF") if $self->{except};
# char errbuf[1024];
# Now do a block of some sort.
$self->{condnum} = 0;
- $self->{cond} = ''; # last CASE: condidional
+ $self->{cond} = ''; # last CASE: conditional
push(@{ $self->{line} }, "$END:");
push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
$_ = '';
- check_cpp($self);
+ check_conditional_preprocessor_statements();
while (@{ $self->{line} }) {
- &CASE_handler if check_keyword("CASE");
+ $self->CASE_handler($_) if $self->check_keyword("CASE");
print Q(<<"EOF");
# $self->{except} [[
EOF
%{ $self->{arg_list} } = ();
$self->{gotRETVAL} = 0;
- INPUT_handler();
- process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
+ $self->INPUT_handler($_);
+ $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ENTER;
}
}
+ my ($wantRETVAL);
# do code
if (/^\s*NOT_IMPLEMENTED_YET/) {
print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
}
else {
if ($self->{ret_type} ne "void") {
- print "\t" . &map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n"
+ print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n"
if !$self->{retvaldone};
$self->{args_match}->{"RETVAL"} = 0;
$self->{var_types}->{"RETVAL"} = $self->{ret_type};
+ my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
print "\tdXSTARG;\n"
- if $self->{optimize} and $targetable{$self->{type_kind}->{$self->{ret_type}}};
+ if $self->{optimize} and $outputmap and $outputmap->targetable;
}
if (@fake_INPUT or @fake_INPUT_pre) {
unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_;
$_ = "";
$self->{processing_arg_with_types} = 1;
- INPUT_handler();
+ $self->INPUT_handler($_);
}
print $self->{deferred};
- process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
+ $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
- if (check_keyword("PPCODE")) {
- print_section();
- death ("PPCODE must be last thing") if @{ $self->{line} };
+ if ($self->check_keyword("PPCODE")) {
+ $self->print_section();
+ death( $self, "PPCODE must be last thing") if @{ $self->{line} };
print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
print "\tPUTBACK;\n\treturn;\n";
}
- elsif (check_keyword("CODE")) {
- print_section();
+ elsif ($self->check_keyword("CODE")) {
+ $self->print_section();
}
elsif (defined($class) and $func_name eq "DESTROY") {
print "\n\t";
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
undef %{ $self->{outargs} };
- process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+ $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
generate_output( {
type => $self->{var_types}->{$_},
print "\t$self->{RETVAL_code}\n";
}
elsif ($self->{gotRETVAL} || $wantRETVAL) {
- my $t = $self->{optimize} && $targetable{$self->{type_kind}->{$self->{ret_type}}};
+ my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
+ my $t = $self->{optimize} && $outputmap && $outputmap->targetable;
# Although the '$var' declared in the next line is never explicitly
# used within this 'elsif' block, commenting it out leads to
# disaster, starting with the first 'eval qq' inside the 'elsif' block
my $var = 'RETVAL';
my $type = $self->{ret_type};
- # 0: type, 1: with_size, 2: how, 3: how_size
- if ($t and not $t->[1] and $t->[0] eq 'p') {
- # PUSHp corresponds to setpvn. Treate setpv directly
- my $what = eval qq("$t->[2]");
+ if ($t and not $t->{with_size} and $t->{type} eq 'p') {
+ # PUSHp corresponds to setpvn. Treat setpv directly
+ my $what = eval qq("$t->{what}");
warn $@ if $@;
print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
$prepush_done = 1;
}
elsif ($t) {
- my $what = eval qq("$t->[2]");
+ my $what = eval qq("$t->{what}");
warn $@ if $@;
- my $tsize = $t->[3];
+ my $tsize = $t->{what_size};
$tsize = '' unless defined $tsize;
$tsize = eval qq("$tsize");
warn $@ if $@;
- print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
+ print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n";
$prepush_done = 1;
}
else {
} ) for @{ $outlist_ref };
# do cleanup
- process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+ $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ]]
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
# ENDHANDLERS
EOF
- if (check_keyword("CASE")) {
- blurt ("Error: No `CASE:' at top of function")
+ if ($self->check_keyword("CASE")) {
+ blurt( $self, "Error: No `CASE:' at top of function")
unless $self->{condnum};
$_ = "CASE: $_"; # Restore CASE: label
next;
}
last if $_ eq "$END:";
- death(/^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
+ death( $self,
+ /^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
}
print Q(<<"EOF") if $self->{except};
if ($self->{Overload}) { # make it findable with fetchmethod
print Q(<<"EOF");
-#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
-#XS(XS_${Packid}_nil)
+#XS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS(XS_$self->{Packid}_nil)
#{
# dXSARGS;
# XSRETURN_EMPTY;
/* Making a sub named "${Package}::()" allows the package */
/* to be findable via fetchmethod(), and causes */
/* overload::Overloaded("${Package}") to return true. */
- (void)$self->{newXS}("${Package}::()", XS_${Packid}_nil, file$self->{proto});
+ (void)$self->{newXS}("${Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
MAKE_FETCHMETHOD_WORK
}
print Q(<<"EOF");
# PERL_UNUSED_VAR(cv); /* -W */
# PERL_UNUSED_VAR(items); /* -W */
+##ifdef XS_APIVERSION_BOOTCHECK
+# XS_APIVERSION_BOOTCHECK;
+##endif
EOF
print Q(<<"EOF") if $self->{WantVersionChk};
if (@{ $BootCode_ref }) {
print "\n /* Initialisation Section */\n\n";
@{ $self->{line} } = @{ $BootCode_ref };
- print_section();
+ $self->print_section();
print "\n /* End of Initialisation Section */\n\n";
}
sub report_error_count { $self->{errors} }
-# Input: ($_, @{ $self->{line} }) == unparsed input.
+# Input: ($self, $_, @{ $self->{line} }) == unparsed input.
# Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
+ my $self = shift;
$_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} };
s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}
sub print_section {
+ my $self = shift;
+
# the "do" is required for right semantics
do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} };
}
sub merge_section {
+ my $self = shift;
my $in = '';
while (!/\S/ && @{ $self->{line} }) {
return $in;
}
-sub process_keyword($) {
- my($pattern) = @_;
- my $kwd;
+sub process_keyword {
+ my($self, $pattern) = @_;
- no strict 'refs';
- &{"${kwd}_handler"}()
- while $kwd = check_keyword($pattern);
- use strict 'refs';
+ while (my $kwd = $self->check_keyword($pattern)) {
+ my $method = $kwd . "_handler";
+ $self->$method($_);
+ }
}
sub CASE_handler {
- blurt ("Error: `CASE:' after unconditional `CASE:'")
+ my $self = shift;
+ $_ = shift;
+ blurt( $self, "Error: `CASE:' after unconditional `CASE:'")
if $self->{condnum} && $self->{cond} eq '';
$self->{cond} = $_;
trim_whitespace($self->{cond});
}
sub INPUT_handler {
+ my $self = shift;
+ $_ = shift;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
last if /^\s*NOT_IMPLEMENTED_YET/;
next unless /\S/; # skip blank lines
s/\s+/ /g;
my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
- or blurt("Error: invalid argument declaration '$ln'"), next;
+ or blurt( $self, "Error: invalid argument declaration '$ln'"), next;
# Check for duplicate definitions
- blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
+ blurt( $self, "Error: duplicate definition of argument '$var_name' ignored"), next
if $self->{arg_list}->{$var_name}++
or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types};
# one can use 2-args map_type() unconditionally.
my $printed_name;
if ($var_type =~ / \( \s* \* \s* \) /x) {
- # Function pointers are not yet supported with &output_init!
- print "\t" . &map_type($var_type, $var_name, $self->{hiertype});
+ # Function pointers are not yet supported with output_init()!
+ print "\t" . map_type($self, $var_type, $var_name);
$printed_name = 1;
}
else {
- print "\t" . &map_type($var_type, undef, $self->{hiertype});
+ print "\t" . map_type($self, $var_type, undef);
$printed_name = 0;
}
$self->{var_num} = $self->{args_match}->{$var_name};
if ($self->{var_num}) {
- $self->{proto_arg}->[$self->{var_num}] = $self->{proto_letter}->{$var_type} || "\$";
+ my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
+ $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
}
$self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
}
sub OUTPUT_handler {
+ my $self = shift;
+ $_ = shift;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
next;
}
my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
- blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
+ blurt( $self, "Error: duplicate OUTPUT argument '$outarg' ignored"), next
if $self->{outargs}->{$outarg}++;
if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') {
# deal with RETVAL last
$self->{gotRETVAL} = 1;
next;
}
- blurt ("Error: OUTPUT $outarg not an argument"), next
+ blurt( $self, "Error: OUTPUT $outarg not an argument"), next
unless defined($self->{args_match}->{$outarg});
- blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
+ blurt( $self, "Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
unless defined $self->{var_types}->{$outarg};
$self->{var_num} = $self->{args_match}->{$outarg};
if ($outcode) {
}
}
-sub C_ARGS_handler() {
- my $in = merge_section();
+sub C_ARGS_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
$self->{func_args} = $in;
}
-sub INTERFACE_MACRO_handler() {
- my $in = merge_section();
+sub INTERFACE_MACRO_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
if ($in =~ /\s/) { # two
$self->{interfaces} = 1; # global
}
-sub INTERFACE_handler() {
- my $in = merge_section();
+sub INTERFACE_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
$self->{interfaces} = 1; # global
}
-sub CLEANUP_handler() { print_section() }
-sub PREINIT_handler() { print_section() }
-sub POSTCALL_handler() { print_section() }
-sub INIT_handler() { print_section() }
+sub CLEANUP_handler {
+ my $self = shift;
+ $self->print_section();
+}
-sub GetAliases {
+sub PREINIT_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub POSTCALL_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub INIT_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub get_aliases {
+ my $self = shift;
my ($line) = @_;
my ($orig) = $line;
$alias = $self->{Packprefix} . $alias if $alias !~ /::/;
# check for duplicate alias name & duplicate value
- Warn("Warning: Ignoring duplicate alias '$orig_alias'")
+ Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
if defined $self->{XsubAliases}->{$alias};
- Warn("Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
+ Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
if $self->{XsubAliasValues}->{$value};
$self->{xsubaliases} = 1;
$self->{XsubAliasValues}->{$value} = $orig_alias;
}
- blurt("Error: Cannot parse ALIAS definitions from '$orig'")
+ blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")
if $line;
}
-sub ATTRS_handler () {
+sub ATTRS_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
}
}
-sub ALIAS_handler () {
+sub ALIAS_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
- GetAliases($_) if $_;
+ $self->get_aliases($_) if $_;
}
}
-sub OVERLOAD_handler() {
+sub OVERLOAD_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
}
}
-sub FALLBACK_handler() {
+sub FALLBACK_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either TRUE,
# FALSE or UNDEF
);
# check for valid FALLBACK value
- death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
+ death( $self, "Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
$self->{Fallback} = $map{uc $_};
}
-sub REQUIRE_handler () {
+sub REQUIRE_handler {
+ my $self = shift;
# the rest of the current line should contain a version number
- my ($Ver) = $_;
+ my $Ver = shift;
trim_whitespace($Ver);
- death ("Error: REQUIRE expects a version number")
+ death( $self, "Error: REQUIRE expects a version number")
unless $Ver;
# check that the version number is of the form n.n
- death ("Error: REQUIRE: expected a number, got '$Ver'")
+ death( $self, "Error: REQUIRE: expected a number, got '$Ver'")
unless $Ver =~ /^\d+(\.\d*)?/;
- death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
+ death( $self, "Error: xsubpp $Ver (or better) required--this is only $VERSION.")
unless $VERSION >= $Ver;
}
-sub VERSIONCHECK_handler () {
+sub VERSIONCHECK_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either ENABLE or
# DISABLE
trim_whitespace($_);
# check for ENABLE/DISABLE
- death ("Error: VERSIONCHECK: ENABLE/DISABLE")
+ death( $self, "Error: VERSIONCHECK: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i;
$self->{WantVersionChk} = 1 if $1 eq 'ENABLE';
}
-sub PROTOTYPE_handler () {
+sub PROTOTYPE_handler {
+ my $self = shift;
+ $_ = shift;
+
my $specified;
- death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ death( $self, "Error: Only 1 PROTOTYPE definition allowed per xsub")
if $self->{proto_in_this_xsub}++;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
else {
# remove any whitespace
s/\s+//g;
- death("Error: Invalid prototype '$_'")
+ death( $self, "Error: Invalid prototype '$_'")
unless valid_proto_string($_);
$self->{ProtoThisXSUB} = C_string($_);
}
$self->{ProtoUsed} = 1;
}
-sub SCOPE_handler () {
- death("Error: Only 1 SCOPE declaration allowed per xsub")
+sub SCOPE_handler {
+ my $self = shift;
+ $_ = shift;
+
+ death( $self, "Error: Only 1 SCOPE declaration allowed per xsub")
if $self->{scope_in_this_xsub}++;
trim_whitespace($_);
- death ("Error: SCOPE: ENABLE/DISABLE")
+ death("Error: SCOPE: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)\b/i;
$self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' );
}
-sub PROTOTYPES_handler () {
+sub PROTOTYPES_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either ENABLE or
# DISABLE
trim_whitespace($_);
# check for ENABLE/DISABLE
- death ("Error: PROTOTYPES: ENABLE/DISABLE")
+ death("Error: PROTOTYPES: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i;
$self->{WantPrototypes} = 1 if $1 eq 'ENABLE';
$self->{WantPrototypes} = 0 if $1 eq 'DISABLE';
$self->{ProtoUsed} = 1;
-
}
sub PushXSStack {
+ my $self = shift;
my %args = @_;
# Save the current file context.
push(@{ $self->{XSStack} }, {
}
-sub INCLUDE_handler () {
+sub INCLUDE_handler {
+ my $self = shift;
+ $_ = shift;
# the rest of the current line should contain a valid filename
trim_whitespace($_);
- death("INCLUDE: filename missing")
+ death( $self, "INCLUDE: filename missing")
unless $_;
- death("INCLUDE: output pipe is illegal")
+ death( $self, "INCLUDE: output pipe is illegal")
if /^\s*\|/;
# simple minded recursion detector
- death("INCLUDE loop detected")
+ death( $self, "INCLUDE loop detected")
if $self->{IncludedFiles}->{$_};
++$self->{IncludedFiles}->{$_} unless /\|\s*$/;
if (/\|\s*$/ && /^\s*perl\s/) {
- Warn("The INCLUDE directive with a command is discouraged." .
- " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
- " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
- " up the correct perl. The INCLUDE_COMMAND directive allows" .
- " the use of \$^X as the currently running perl, see" .
- " 'perldoc perlxs' for details.");
+ Warn( $self, "The INCLUDE directive with a command is discouraged." .
+ " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
+ " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
+ " up the correct perl. The INCLUDE_COMMAND directive allows" .
+ " the use of \$^X as the currently running perl, see" .
+ " 'perldoc perlxs' for details.");
}
- PushXSStack();
+ $self->PushXSStack();
$FH = Symbol::gensym();
# open the new file
- open ($FH, "$_") or death("Cannot open '$_': $!");
+ open ($FH, "$_") or death( $self, "Cannot open '$_': $!");
print Q(<<"EOF");
#
return join (' ', ($cmd, @args));
}
-sub INCLUDE_COMMAND_handler () {
+sub INCLUDE_COMMAND_handler {
+ my $self = shift;
+ $_ = shift;
# the rest of the current line should contain a valid command
trim_whitespace($_);
$_ = QuoteArgs($_) if $^O eq 'VMS';
- death("INCLUDE_COMMAND: command missing")
+ death( $self, "INCLUDE_COMMAND: command missing")
unless $_;
- death("INCLUDE_COMMAND: pipes are illegal")
+ death( $self, "INCLUDE_COMMAND: pipes are illegal")
if /^\s*\|/ or /\|\s*$/;
- PushXSStack( IsPipe => 1 );
+ $self->PushXSStack( IsPipe => 1 );
$FH = Symbol::gensym();
# open the new file
open ($FH, "-|", "$_")
- or death("Cannot run command '$_' to include its output: $!");
+ or death( $self, "Cannot run command '$_' to include its output: $!");
print Q(<<"EOF");
#
$self->{lastline_no} = $.;
}
-sub PopFile() {
+sub PopFile {
+ my $self = shift;
+
return 0 unless $self->{XSStack}->[-1]{type} eq 'file';
my $data = pop @{ $self->{XSStack} };
return 1;
}
-sub check_cpp {
- my ($self) = @_;
- my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
- if (@cpp) {
- my ($cpp, $cpplevel);
- for $cpp (@cpp) {
- if ($cpp =~ /^\#\s*if/) {
- $cpplevel++;
- }
- elsif (!$cpplevel) {
- Warn("Warning: #else/elif/endif without #if in this function");
- print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
- if $self->{XSStack}->[-1]{type} eq 'if';
- return;
- }
- elsif ($cpp =~ /^\#\s*endif/) {
- $cpplevel--;
- }
- }
- Warn("Warning: #if without #endif in this function") if $cpplevel;
- }
-}
-
-
sub Q {
my($text) = @_;
$text =~ s/^#//gm;
# Read next xsub into @{ $self->{line} } from ($lastline, <$FH>).
sub fetch_para {
+ my $self = shift;
+
# parse paragraph
- death ("Error: Unterminated `#if/#ifdef/#ifndef'")
+ death("Error: Unterminated `#if/#ifdef/#ifndef'")
if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
@{ $self->{line} } = ();
@{ $self->{line_no} } = ();
- return PopFile() if !defined $self->{lastline};
+ return $self->PopFile() if !defined $self->{lastline};
if ($self->{lastline} =~
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
$self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy
$self->{Prefix} = quotemeta $self->{Prefix};
($self->{Module_cname} = $Module) =~ s/\W/_/g;
- ($Packid = $Package) =~ tr/:/_/;
+ ($self->{Packid} = $Package) =~ tr/:/_/;
$self->{Packprefix} = $Package;
$self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
$self->{lastline} = "";
while ($self->{lastline} = <$FH>) {
last if ($self->{lastline} =~ /^=cut\s*$/);
}
- death ("Error: Unterminated pod") unless $self->{lastline};
+ death("Error: Unterminated pod") unless $self->{lastline};
$self->{lastline} = <$FH>;
chomp $self->{lastline};
$self->{lastline} =~ s/^\s+$//;
$argsref->{printed_name},
);
my $arg = "ST(" . ($num - 1) . ")";
- my ($argoff, $ntype, $tk);
+ my ($argoff, $ntype);
$argoff = $num - 1;
+ my $typemaps = $self->{typemap};
+
$type = tidy_type($type);
- blurt("Error: '$type' not in typemap"), return
- unless defined($self->{type_kind}->{$type});
+ blurt( $self, "Error: '$type' not in typemap"), return
+ unless $typemaps->get_typemap(ctype => $type);
($ntype = $type) =~ s/\s*\*/Ptr/g;
my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
- $tk = $self->{type_kind}->{$type};
- $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
- if ($tk eq 'T_PV' and exists $self->{lengthof}->{$var}) {
+ my $typem = $typemaps->get_typemap(ctype => $type);
+ my $xstype = $typem->xstype;
+ $xstype =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+ if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
print "\t$var" unless $printed_name;
print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
die "default value not supported with length(NAME) supplied"
return;
}
$type =~ tr/:/_/ unless $self->{hiertype};
- blurt("Error: No INPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
- unless defined $self->{input_expr}->{$tk};
- my $expr = $self->{input_expr}->{$tk};
+
+ my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
+ blurt( $self, "Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return
+ unless defined $inputmap;
+
+ my $expr = $inputmap->cleaned_code;
+ # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
- unless defined($self->{type_kind}->{$subtype});
- blurt("Error: No INPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
- unless defined $self->{input_expr}->{$self->{type_kind}->{$subtype}};
- my $subexpr = $self->{input_expr}->{$self->{type_kind}->{$subtype}};
+ my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
+ my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
+ blurt( $self, "Error: '$subtype' not in typemap"), return
+ unless $subtypemap;
+ blurt( $self, "Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+ unless $subinputmap;
+ my $subexpr = $subinputmap->cleaned_code;
$subexpr =~ s/\$type/\$subtype/g;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
my $arg = "ST(" . ($num - ($num != 0)) . ")";
my $ntype;
+ my $typemaps = $self->{typemap};
+
$type = tidy_type($type);
if ($type =~ /^array\(([^,]*),(.*)\)/) {
print "\t$arg = sv_newmortal();\n";
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
}
else {
- blurt("Error: '$type' not in typemap"), return
- unless defined($self->{type_kind}->{$type});
- blurt("Error: No OUTPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
- unless defined $self->{output_expr}->{$self->{type_kind}->{$type}};
+ my $typemap = $typemaps->get_typemap(ctype => $type);
+ my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
+ blurt( $self, "Error: '$type' not in typemap"), return
+ unless $typemap;
+ blurt( $self, "Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return
+ unless $outputmap;
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
- my $expr = $self->{output_expr}->{$self->{type_kind}->{$type}};
+
+ my $expr = $outputmap->cleaned_code;
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
- unless defined($self->{type_kind}->{$subtype});
- blurt("Error: No OUTPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
- unless defined $self->{output_expr}->{$self->{type_kind}->{$subtype}};
- my $subexpr = $self->{output_expr}->{$self->{type_kind}->{$subtype}};
+ my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
+ my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
+ blurt( $self, "Error: '$subtype' not in typemap"), return
+ unless $subtypemap;
+ blurt( $self, "Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+ unless $suboutputmap;
+ my $subexpr = $suboutputmap->cleaned_code;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\$var/${var}[ix_$var]/g;
}
}
-sub Warn {
- # work out the line number
- my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
-
- print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
-}
-
-sub blurt {
- Warn @_;
- $self->{errors}++
-}
-
-sub death {
- Warn @_;
- exit 1;
-}
-
-sub print_preprocessor_statements {
- my ($self, $XSS_work_idx, $BootCode_ref) = @_;
-
- my $statement = $+;
- if ($statement eq 'if') {
- $XSS_work_idx = @{ $self->{XSStack} };
- push(@{ $self->{XSStack} }, {type => 'if'});
- }
- else {
- death ("Error: `$statement' with no matching `if'")
- if $self->{XSStack}->[-1]{type} ne 'if';
- if ($self->{XSStack}->[-1]{varname}) {
- push(@{ $self->{InitFileCode} }, "#endif\n");
- push(@{ $BootCode_ref }, "#endif");
- }
-
- my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
- if ($statement ne 'endif') {
- # Hide the functions defined in other #if branches, and reset.
- @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
- @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
- }
- else {
- my($tmp) = pop(@{ $self->{XSStack} });
- 0 while (--$XSS_work_idx
- && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
- # Keep all new defined functions
- push(@fns, keys %{$tmp->{other_functions}});
- @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
- }
- }
- return ($self, $XSS_work_idx, $BootCode_ref);
-}
-
1;
+
+# vim: ts=2 sw=2 et:
https://perl5.git.perl.org / perl5.git / blobdiff