xsubpp

ARM上的如果你对底层感兴趣

    }
}

sub REQUIRE_handler ()
{
    # the rest of the current line should contain a version number
    my ($Ver) = $_ ;

    TrimWhitespace($Ver) ;

    death ("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'")
	unless $Ver =~ /^\d+(\.\d*)?/ ;

    death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
        unless $XSUBPP_version >= $Ver ; 
}

sub VERSIONCHECK_handler ()
{
    # the rest of the current line should contain either ENABLE or
    # DISABLE
 
    TrimWhitespace($_) ;
 
    # check for ENABLE/DISABLE
    death ("Error: VERSIONCHECK: ENABLE/DISABLE")
        unless /^(ENABLE|DISABLE)/i ;
 
    $WantVersionChk = 1 if $1 eq 'ENABLE' ;
    $WantVersionChk = 0 if $1 eq 'DISABLE' ;
 
}

sub PROTOTYPE_handler ()
{
    my $specified ;

    death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
        if $proto_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	next unless /\S/;
	$specified = 1 ;
	TrimWhitespace($_) ;
        if ($_ eq 'DISABLE') {
	   $ProtoThisXSUB = 0 
        }
        elsif ($_ eq 'ENABLE') {
	   $ProtoThisXSUB = 1 
        }
        else {
            # remove any whitespace
            s/\s+//g ;
            death("Error: Invalid prototype '$_'")
                unless ValidProtoString($_) ;
            $ProtoThisXSUB = C_string($_) ;
        }
    }

    # If no prototype specified, then assume empty prototype ""
    $ProtoThisXSUB = 2 unless $specified ;

    $ProtoUsed = 1 ;

}

sub SCOPE_handler ()
{
    death("Error: Only 1 SCOPE declaration allowed per xsub") 
        if $scope_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
		next unless /\S/;
		TrimWhitespace($_) ;
        if ($_ =~ /^DISABLE/i) {
		   $ScopeThisXSUB = 0 
        }
        elsif ($_ =~ /^ENABLE/i) {
		   $ScopeThisXSUB = 1 
        }
    }

}

sub PROTOTYPES_handler ()
{
    # the rest of the current line should contain either ENABLE or
    # DISABLE 

    TrimWhitespace($_) ;

    # check for ENABLE/DISABLE
    death ("Error: PROTOTYPES: ENABLE/DISABLE")
        unless /^(ENABLE|DISABLE)/i ;

    $WantPrototypes = 1 if $1 eq 'ENABLE' ;
    $WantPrototypes = 0 if $1 eq 'DISABLE' ;
    $ProtoUsed = 1 ;

}

sub INCLUDE_handler ()
{
    # the rest of the current line should contain a valid filename
 
    TrimWhitespace($_) ;
 
    death("INCLUDE: filename missing")
        unless $_ ;

    death("INCLUDE: output pipe is illegal")
        if /^\s*\|/ ;

    # simple minded recursion detector
    death("INCLUDE loop detected")
        if $IncludedFiles{$_} ;

    ++ $IncludedFiles{$_} unless /\|\s*$/ ;

    # Save the current file context.
    push(@XSStack, {
	type		=> 'file',
        LastLine        => $lastline,
        LastLineNo      => $lastline_no,
        Line            => \@line,
        LineNo          => \@line_no,
        Filename        => $filename,
        Handle          => $FH,
        }) ;
 
    ++ $FH ;

    # open the new file
    open ($FH, "$_") or death("Cannot open '$_': $!") ;
 
    print Q<<"EOF" ;
#
#/* INCLUDE:  Including '$_' from '$filename' */
#
EOF

    $filename = $_ ;

    # Prime the pump by reading the first 
    # non-blank line

    # skip leading blank lines
    while (<$FH>) {
        last unless /^\s*$/ ;
    }

    $lastline = $_ ;
    $lastline_no = $. ;
 
}
 
sub PopFile()
{
    return 0 unless $XSStack[-1]{type} eq 'file' ;

    my $data     = pop @XSStack ;
    my $ThisFile = $filename ;
    my $isPipe   = ($filename =~ /\|\s*$/) ;
 
    -- $IncludedFiles{$filename}
        unless $isPipe ;

    close $FH ;

    $FH         = $data->{Handle} ;
    $filename   = $data->{Filename} ;
    $lastline   = $data->{LastLine} ;
    $lastline_no = $data->{LastLineNo} ;
    @line       = @{ $data->{Line} } ;
    @line_no    = @{ $data->{LineNo} } ;

    if ($isPipe and $? ) {
        -- $lastline_no ;
        print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
        exit 1 ;
    }

    print Q<<"EOF" ;
#
#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
#
EOF

    return 1 ;
}

sub ValidProtoString ($)
{
    my($string) = @_ ;

    if ( $string =~ /^$proto_re+$/ ) {
        return $string ;
    }

    return 0 ;
}

sub C_string ($)
{
    my($string) = @_ ;

    $string =~ s[\\][\\\\]g ;
    $string ;
}

sub ProtoString ($)
{
    my ($type) = @_ ;

    $proto_letter{$type} or "\$" ;
}

sub check_cpp {
    my @cpp = grep(/^\#\s*(?:if|e\w+)/, @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 $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;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    $text;
}

open($FH, $filename) or die "cannot open $filename: $!\n";

# Identify the version of xsubpp used
print <<EOM ;
/*
 * This file was generated automatically by xsubpp version $XSUBPP_version from the 
 * contents of $filename. Do not edit this file, edit $filename instead.
 *
 *	ANY CHANGES MADE HERE WILL BE LOST! 
 *
 */

EOM
 

print("#line 1 \"$filename\"\n")
    if $WantLineNumbers;

while (<$FH>) {
    last if ($Module, $Package, $Prefix) =
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;

    if ($OBJ) {
        s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
    }
    print $_;
}
&Exit unless defined $_;

print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;

$lastline    = $_;
$lastline_no = $.;

# Read next xsub into @line from ($lastline, <$FH>).
sub fetch_para {
    # parse paragraph
    death ("Error: Unterminated `#if/#ifdef/#ifndef'")
	if !defined $lastline && $XSStack[-1]{type} eq 'if';
    @line = ();
    @line_no = () ;
    return PopFile() if !defined $lastline;

    if ($lastline =~
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
	$Module = $1;
	$Package = defined($2) ? $2 : '';	# keep -w happy
	$Prefix  = defined($3) ? $3 : '';	# keep -w happy
	$Prefix = quotemeta $Prefix ;
	($Module_cname = $Module) =~ s/\W/_/g;
	($Packid = $Package) =~ tr/:/_/;
	$Packprefix = $Package;
	$Packprefix .= "::" if $Packprefix ne "";
	$lastline = "";
    }

    for(;;) {
	if ($lastline !~ /^\s*#/ ||
	    # CPP directives:
	    #	ANSI:	if ifdef ifndef elif else endif define undef
	    #		line error pragma
	    #	gcc:	warning include_next
	    #   obj-c:	import
	    #   others:	ident (gcc notes that some cpps have this one)
	    $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
	    last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
	    push(@line, $lastline);
	    push(@line_no, $lastline_no) ;
	}

	# Read next line and continuation lines
	last unless defined($lastline = <$FH>);
	$lastline_no = $.;
	my $tmp_line;
	$lastline .= $tmp_line
	    while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
	    
	chomp $lastline;
	$lastline =~ s/^\s+$//;
    }
    pop(@line), pop(@line_no) while @line && $line[-1] eq "";
    1;
}

PARAGRAPH:
while (fetch_para()) {
    # Print initial preprocessor statements and blank lines
    while (@line && $line[0] !~ /^[^\#]/) {
	my $line = shift(@line);
	print $line, "\n";
	next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
	my $statement = $+;
	if ($statement eq 'if') {
	    $XSS_work_idx = @XSStack;
	    push(@XSStack, {type => 'if'});
	} else {
	    death ("Error: `$statement' with no matching `if'")
		if $XSStack[-1]{type} ne 'if';
	    if ($XSStack[-1]{varname}) {
		push(@InitFileCode, "#endif\n");
		push(@BootCode,     "#endif");
	    }

	    my(@fns) = keys %{$XSStack[-1]{functions}};
	    if ($statement ne 'endif') {
		# Hide the functions defined in other #if branches, and reset.
		@{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
		@{$XSStack[-1]}{qw(varname functions)} = ('', {});
	    } else {
		my($tmp) = pop(@XSStack);
		0 while (--$XSS_work_idx
			 && $XSStack[$XSS_work_idx]{type} ne 'if');
		# Keep all new defined functions
		push(@fns, keys %{$tmp->{other_functions}});
		@{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
	    }
	}
    }

    next PARAGRAPH unless @line;

    if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
	# We are inside an #if, but have not yet #defined its xsubpp variable.
	print "#define $cpp_next_tmp 1\n\n";
	push(@InitFileCode, "#if $cpp_next_tmp\n");
	push(@BootCode,     "#if $cpp_next_tmp");
	$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 a statement on column one?)")
	if $line[0] =~ /^\s/;

    # initialize info arrays
    undef(%args_match);
    undef(%var_types);
    undef(%var_addr);
    undef(%defaults);
    undef($class);
    undef($static);
    undef($elipsis);
    undef($wantRETVAL) ;
    undef(%arg_list) ;
    undef(@proto_arg) ;
    undef($proto_in_this_xsub) ;
    undef($scope_in_this_xsub) ;
    undef($interface);
    $interface_macro = 'XSINTERFACE_FUNC' ;
    $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
    $ProtoThisXSUB = $WantPrototypes ;
    $ScopeThisXSUB = 0;

    $_ = shift(@line);
    while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
        &{"${kwd}_handler"}() ;
        next PARAGRAPH unless @line ;
        $_ = shift(@line);
    }

    if (check_keyword("BOOT")) {
	&check_cpp;
	push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
	  if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
        push (@BootCode, @line, "") ;
        next PARAGRAPH ;
    }


    # extract return type, function name and arguments
    ($ret_type) = TidyType($_);

    # a function definition needs at least 2 lines
    blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
	unless @line ;

    $static = 1 if $ret_type =~ s/^static\s+//;

    $func_header = shift(@line);
    blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
	unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s;

    ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
    $class = "$4 $class" if $4;
    ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
    ($clean_func_name = $func_name) =~ s/^$Prefix//;
    $Full_func_name = "${Packid}_$clean_func_name";
    if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }

    # Check for duplicate function definition
    for $tmp (@XSStack) {
	next unless defined $tmp->{functions}{$Full_func_name};
	Warn("Warning: duplicate function definition '$clean_func_name' detected");
	last;
    }
    $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
    %XsubAliases = %XsubAliasValues = %Interfaces = ();
    $DoSetMagic = 1;

    @args = split(/\s*,\s*/, $orig_args);
    if (defined($class)) {
	my $arg0 = ((defined($static) or $func_name eq 'new')
		    ? "CLASS" : "THIS");
	unshift(@args, $arg0);
	($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
    }
    $orig_args =~ s/"/\\"/g;
    $min_args = $num_args = @args;
    foreach $i (0..$num_args-1) {
	    if ($args[$i] =~ s/\.\.\.//) {
		    $elipsis = 1;
		    $min_args--;
		    if ($args[$i] eq '' && $i == $num_args - 1) {
			pop(@args);
			last;
		    }
	    }
	    if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
		    $min_args--;
		    $args[$i] = $1;
		    $defaults{$args[$i]} = $2;
		    $defaults{$args[$i]} =~ s/"/\\"/g;
	    }
	    $proto_arg[$i+1] = "\$" ;
    }
    if (defined($class)) {
	    $func_args = join(", ", @args[1..$#args]);
    } else {
	    $func_args = join(", ", @args);
    }
    @args_match{@args} = 1..@args;

    $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
    $CODE = grep(/^\s*CODE\s*:/, @line);
    # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
    #   to set explicit return values.
    $EXPLICIT_RETURN = ($CODE &&
		("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
    $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
    $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @line);

    # print function header
    print Q<<"EOF";
#XS(XS_${Full_func_name})
#[[
#    dXSARGS;
EOF
    print Q<<"EOF" if $ALIAS ;
#    dXSI32;
EOF
    print Q<<"EOF" if $INTERFACE ;
#    dXSFUNCTION($ret_type);
EOF
    if ($elipsis) {
	$cond = ($min_args ? qq(items < $min_args) : 0);