5 xsubpp - compiler to convert Perl XS code into C code
9 B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-noprototypes>] [B<-typemap typemap>]... file.xs
13 I<xsubpp> will compile XS code into C code by embedding the constructs
14 necessary to let C functions manipulate Perl values and creates the glue
15 necessary to let Perl access those functions. The compiler uses typemaps to
16 determine how to map C function parameters and variables to Perl values.
18 The compiler will search for typemap files called I<typemap>. It will use
19 the following search path to find default typemaps, with the rightmost
20 typemap taking precedence.
22 ../../../typemap:../../typemap:../typemap:typemap
30 Adds ``extern "C"'' to the C code.
35 Adds exception handling stubs to the C code.
37 =item B<-typemap typemap>
39 Indicates that a user-supplied typemap should take precedence over the
40 default typemaps. This option may be used multiple times, with the last
41 typemap having the highest precedence.
45 Prints the I<xsubpp> version number to standard output, then exits.
47 =item B<-noprototypes>
54 No environment variables are used.
60 =head1 MODIFICATION HISTORY
62 See the file F<changes.pod>.
71 $XSUBPP_version = "1.924";
74 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-noprototypes] [-s pattern] [-typemap typemap]... file.xs\n";
76 $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
80 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
83 $spat = shift, next SWITCH if $flag eq 's';
84 $cplusplus = 1, next SWITCH if $flag eq 'C++';
85 $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
86 $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
87 $except = " TRY", next SWITCH if $flag eq 'except';
88 push(@tm,shift), next SWITCH if $flag eq 'typemap';
89 (print "xsubpp version $XSUBPP_version\n"), exit
93 @ARGV == 1 or die $usage;
95 # Check for error message from VMS
96 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
97 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
98 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
99 or ($dir, $filename) = ('.', $ARGV[0]);
104 $_[0] =~ s/^\s+|\s+$//go ;
111 # rationalise any '*' by joining them into bunches and removing whitespace
115 # change multiple whitespace into a single space
118 # trim leading & trailing whitespace
124 $typemap = shift @ARGV;
125 foreach $typemap (@tm) {
126 die "Can't find $typemap in $pwd\n" unless -r $typemap;
128 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
129 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
131 foreach $typemap (@tm) {
132 next unless -e $typemap ;
133 # skip directories, binary files etc.
134 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
136 open(TYPEMAP, $typemap)
137 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
143 if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
144 if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
145 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
146 if ($mode eq 'Typemap') {
150 # skip blank lines and comment lines
151 next if /^$/ or /^#/ ;
152 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
153 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
154 $type = TidyType($type) ;
155 $type_kind{$type} = $kind ;
156 # prototype defaults to '$'
157 $proto = '$' unless $proto ;
158 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
159 unless ValidProtoString($proto) ;
160 $proto_letter{$type} = C_string($proto) ;
165 elsif ($mode eq 'Input') {
167 $input_expr{$_} = '';
168 $current = \$input_expr{$_};
172 $output_expr{$_} = '';
173 $current = \$output_expr{$_};
179 foreach $key (keys %input_expr) {
180 $input_expr{$key} =~ s/\n+$//;
183 $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
185 # Match an XS keyword
186 $BLOCK_re= '\s*(' . join('|', qw(
187 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
188 CLEANUP ALIAS PROTOTYPES PROTOTYPE
191 # Input: ($_, @line) == unparsed input.
192 # Output: ($_, @line) == (rest of line, following lines).
193 # Return: the matched keyword if found, otherwise 0
195 $_ = shift(@line) while !/\S/ && @line;
196 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
201 $_ = shift(@line) while !/\S/ && @line;
202 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
208 blurt ("Error: `CASE:' after unconditional `CASE:'")
209 if $condnum && $cond eq '';
211 TrimWhitespace($cond);
212 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
217 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
218 last if /^\s*NOT_IMPLEMENTED_YET/;
219 next unless /\S/; # skip blank lines
224 # remove trailing semicolon if no initialisation
225 s/\s*;$//g unless /=/ ;
227 # check for optional initialisation code
229 $var_init = $1 if s/\s*(=.*)$//s ;
230 $var_init =~ s/"/\\"/g;
233 my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
234 or blurt("Error: invalid argument declaration '$line'"), next;
236 # Check for duplicate definitions
237 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
238 if $arg_list{$var_name} ++ ;
240 $thisdone |= $var_name eq "THIS";
241 $retvaldone |= $var_name eq "RETVAL";
242 $var_types{$var_name} = $var_type;
243 print "\t" . &map_type($var_type);
244 $var_num = $args_match{$var_name};
246 $proto_arg[$var_num] = ProtoString($var_type) ;
248 $var_addr{$var_name} = 1;
249 $func_args =~ s/\b($var_name)\b/&$1/;
251 if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
252 print "\t$var_name;\n";
253 } elsif ($var_init =~ /\S/) {
254 &output_init($var_type, $var_num, "$var_name $var_init");
256 # generate initialization code
257 &generate_init($var_type, $var_num, $var_name);
265 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
267 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
268 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
269 if $outargs{$outarg} ++ ;
270 if (!$gotRETVAL and $outarg eq 'RETVAL') {
271 # deal with RETVAL last
272 $RETVAL_code = $outcode ;
276 blurt ("Error: OUTPUT $outarg not an argument"), next
277 unless defined($args_match{$outarg});
278 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
279 unless defined $var_types{$outarg} ;
281 print "\t$outcode\n";
283 $var_num = $args_match{$outarg};
284 &generate_output($var_types{$outarg}, $var_num, $outarg);
296 # Parse alias definitions
298 # alias = value alias = value ...
300 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
302 $orig_alias = $alias ;
305 # check for optional package definition in the alias
306 $alias = $Packprefix . $alias if $alias !~ /::/ ;
308 # check for duplicate alias name & duplicate value
309 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
310 if defined $XsubAliases{$pname}{$alias} ;
312 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
313 if $XsubAliasValues{$pname}{$value} ;
315 $XsubAliases{$pname}{$alias} = $value ;
316 $XsubAliasValues{$pname}{$value} = $orig_alias ;
319 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
325 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
328 GetAliases($_) if $_ ;
332 sub REQUIRE_handler ()
334 # the rest of the current line should contain a version number
337 TrimWhitespace($Ver) ;
339 death ("Error: REQUIRE expects a version number")
342 # check that the version number is of the form n.n
343 death ("Error: REQUIRE: expected a number, got '$Ver'")
344 unless $Ver =~ /^\d+(\.\d*)?/ ;
346 death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
347 unless $XSUBPP_version >= $Ver ;
350 sub PROTOTYPE_handler ()
352 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
355 if ($_ eq 'DISABLE') {
358 elsif ($_ eq 'ENABLE') {
362 # remove any whitespace
364 death("Error: Invalid prototype '$_'")
365 unless ValidProtoString($_) ;
366 $ProtoThisXSUB = C_string($_) ;
371 sub PROTOTYPES_handler ()
373 # the rest of the current line should contain either ENABLE or
378 # check for ENABLE/DISABLE
379 death ("Error: PROTOTYPES: ENABLE/DISABLE")
380 unless /^(ENABLE|DISABLE)/i ;
382 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
383 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
387 sub ValidProtoString ($)
391 if ( $string =~ /^$proto_re+$/ ) {
402 $string =~ s[\\][\\\\]g ;
410 $proto_letter{$type} or '$' ;
414 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
416 my ($cpp, $cpplevel);
418 if ($cpp =~ /^\#\s*if/) {
420 } elsif (!$cpplevel) {
421 Warn("Warning: #else/elif/endif without #if in this function");
423 } elsif ($cpp =~ /^\#\s*endif/) {
427 Warn("Warning: #if without #endif in this function") if $cpplevel;
440 open(F, $filename) or die "cannot open $filename: $!\n";
442 # Identify the version of xsubpp used
445 * This file was generated automatically by xsubpp version $XSUBPP_version from the
446 * contents of $filename. Don't edit this file, edit $filename instead.
448 * ANY CHANGES MADE HERE WILL BE LOST!
456 last if ($Module, $Package, $Prefix) =
457 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
460 &Exit unless defined $_;
463 my $lastline_no = $.;
466 # Read next xsub into @line from ($lastline, <F>).
471 return 0 unless defined $lastline;
474 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
476 $Package = defined($2) ? $2 : ''; # keep -w happy
477 $Prefix = defined($3) ? $3 : ''; # keep -w happy
478 ($Module_cname = $Module) =~ s/\W/_/g;
479 ($Packid = $Package) =~ tr/:/_/;
480 $Packprefix = $Package;
481 $Packprefix .= "::" if $Packprefix ne "";
486 if ($lastline !~ /^\s*#/ ||
487 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
488 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
489 push(@line, $lastline);
490 push(@line_no, $lastline_no) ;
493 # Read next line and continuation lines
494 last unless defined($lastline = <F>);
497 $lastline .= $tmp_line
498 while ($lastline =~ /\\$/ && defined($tmp_line = <F>));
501 $lastline =~ s/^\s+$//;
503 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
508 while (fetch_para()) {
509 # Print initial preprocessor statements and blank lines
510 print shift(@line), "\n"
511 while @line && $line[0] !~ /^[^\#]/;
513 next PARAGRAPH unless @line;
515 death ("Code is not inside a function")
516 if $line[0] =~ /^\s/;
518 # initialize info arrays
529 $ProtoThisXSUB = $WantPrototypes ;
532 while ($kwd = check_keyword("REQUIRE|PROTOTYPES")) {
533 if ($kwd eq 'REQUIRE')
534 { REQUIRE_handler() }
536 { PROTOTYPES_handler() }
537 next PARAGRAPH unless @line ;
541 if (check_keyword("BOOT")) {
543 push (@BootCode, $_, @line, "") ;
548 # extract return type, function name and arguments
549 my($ret_type) = TidyType($_);
551 # a function definition needs at least 2 lines
552 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
555 $static = 1 if $ret_type =~ s/^static\s+//;
557 $func_header = shift(@line);
558 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
559 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
561 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
562 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
564 # Check for duplicate function definition
565 if (defined $Func_name{"${Packid}_$func_name"} ) {
566 Warn("Warning: duplicate function definition '$func_name' detected")
569 push(@Func_name, "${Packid}_$func_name");
570 push(@Func_pname, $pname);
572 $Func_name{"${Packid}_$func_name"} ++ ;
574 @args = split(/\s*,\s*/, $orig_args);
575 if (defined($class)) {
576 my $arg0 = (defined($static) ? "CLASS" : "THIS");
577 unshift(@args, $arg0);
578 ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
580 $orig_args =~ s/"/\\"/g;
581 $min_args = $num_args = @args;
582 foreach $i (0..$num_args-1) {
583 if ($args[$i] =~ s/\.\.\.//) {
586 if ($args[$i] eq '' && $i == $num_args - 1) {
591 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
594 $defaults{$args[$i]} = $2;
595 $defaults{$args[$i]} =~ s/"/\\"/g;
597 $proto_arg[$i+1] = '$' ;
599 if (defined($class)) {
600 $func_args = join(", ", @args[1..$#args]);
602 $func_args = join(", ", @args);
604 @args_match{@args} = 1..@args;
606 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
607 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
609 # print function header
611 #XS(XS_${Packid}_$func_name)
615 print Q<<"EOF" if $ALIAS ;
619 $cond = ($min_args ? qq(items < $min_args) : 0);
621 elsif ($min_args == $num_args) {
622 $cond = qq(items != $min_args);
625 $cond = qq(items < $min_args || items > $num_args);
628 print Q<<"EOF" if $except;
634 { print Q<<"EOF" if $cond }
636 # croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
639 { print Q<<"EOF" if $cond }
641 # croak("Usage: $pname($orig_args)");
644 print Q<<"EOF" if $PPCODE;
648 # Now do a block of some sort.
651 $cond = ''; # last CASE: condidional
652 push(@line, "$END:");
653 push(@line_no, $line_no[-1]);
657 &CASE_handler if check_keyword("CASE");
662 # do initialization of input variables
671 while ($kwd = check_keyword("INPUT|PREINIT")) {
672 if ($kwd eq 'PREINIT') { &print_section; } else { &INPUT_handler; }
674 if (!$thisdone && defined($class)) {
675 if (defined($static)) {
677 $var_types{"CLASS"} = "char *";
678 &generate_init("char *", 1, "CLASS");
682 $var_types{"THIS"} = "$class *";
683 &generate_init("$class *", 1, "THIS");
688 if (/^\s*NOT_IMPLEMENTED_YET/) {
689 print "\n\tcroak(\"$pname: not implemented yet\");\n";
692 if ($ret_type ne "void") {
693 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
695 $args_match{"RETVAL"} = 0;
696 $var_types{"RETVAL"} = $ret_type;
699 while ($kwd = check_keyword("INIT|ALIAS|PROTOTYPE")) {
700 if ($kwd eq 'INIT') {
703 elsif ($kwd eq 'PROTOTYPE')
704 { PROTOTYPE_handler() }
709 if (check_keyword("PPCODE")) {
711 death ("PPCODE must be last thing") if @line;
712 print "\tPUTBACK;\n\treturn;\n";
713 } elsif (check_keyword("CODE")) {
715 } elsif ($func_name eq "DESTROY") {
717 print "delete THIS;\n";
720 if ($ret_type ne "void") {
724 if (defined($static)) {
725 if ($func_name =~ /^new/) {
726 $func_name .= " $class";
730 } elsif (defined($class)) {
733 $func_name =~ s/^($spat)//
735 print "$func_name($func_args);\n";
739 # do output variables
743 &OUTPUT_handler while check_keyword("OUTPUT");
745 # all OUTPUT done, so now push the return value on the stack
746 if ($gotRETVAL && $RETVAL_code) {
747 print "\t$RETVAL_code\n";
748 } elsif ($gotRETVAL || $wantRETVAL) {
749 &generate_output($ret_type, 0, 'RETVAL');
753 &print_section while check_keyword("CLEANUP");
755 # print function trailer
759 print Q<<EOF if $except;
762 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
765 if (check_keyword("CASE")) {
766 blurt ("Error: No `CASE:' at top of function")
768 $_ = "CASE: $_"; # Restore CASE: label
771 last if $_ eq "$END:";
772 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
775 print Q<<EOF if $except;
780 print Q<<EOF unless $PPCODE;
789 # Build the prototype string for the xsub
790 if ($ProtoThisXSUB) {
791 if ($ProtoThisXSUB != 1) {
792 $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"'
796 if ($min_args < $num_args) {
798 $proto_arg[$min_args] .= ";" ;
800 push @proto_arg, "${s}@"
803 $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"'
809 # print initialization routine
814 #XS(boot_$Module_cname)
817 # char* file = __FILE__;
821 print Q<<"EOF" if defined %XsubAliases ;
828 $pname = shift(@Func_pname);
829 my $newXS = "newXS" ;
832 if ($ProtoXSUB{$pname}) {
833 $newXS = "newXSproto" ;
834 $proto = ", $ProtoXSUB{$pname}" ;
837 if ($XsubAliases{$pname}) {
838 $XsubAliases{$pname}{$pname} = 0
839 unless defined $XsubAliases{$pname}{$pname} ;
840 while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
842 # cv = newXS(\"$name\", XS_$_, file);
843 # XSANY.any_i32 = $value ;
845 print Q<<"EOF" if $proto ;
846 # sv_setpv(cv, $ProtoXSUB{$pname}) ;
851 print " ${newXS}(\"$pname\", XS_$_, file$proto);\n";
855 print Q<<"EOF" if defined %XsubAliases ;
861 print "\n /* Initialisation Section */\n" ;
862 print grep (s/$/\n/, @BootCode) ;
863 print "\n /* End of Initialisation Section */\n\n" ;
876 local($type, $num, $init) = @_;
877 local($arg) = "ST(" . ($num - 1) . ")";
879 eval qq/print " $init\\\n"/;
884 # work out the line number
885 my $line_no = $line_no[@line_no - @line -1] ;
887 print STDERR "@_ in $filename, line $line_no\n" ;
903 local($type, $num, $var) = @_;
904 local($arg) = "ST(" . ($num - 1) . ")";
905 local($argoff) = $num - 1;
909 $type = TidyType($type) ;
910 blurt("Error: '$type' not in typemap"), return
911 unless defined($type_kind{$type});
913 ($ntype = $type) =~ s/\s*\*/Ptr/g;
914 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
915 $tk = $type_kind{$type};
916 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
918 blurt("Error: No INPUT definition for type '$type' found"), return
919 unless defined $input_expr{$tk} ;
920 $expr = $input_expr{$tk};
921 if ($expr =~ /DO_ARRAY_ELEM/) {
922 blurt("Error: '$subtype' not in typemap"), return
923 unless defined($type_kind{$subtype});
924 blurt("Error: No INPUT definition for type '$subtype' found"), return
925 unless defined $input_expr{$type_kind{$subtype}} ;
926 $subexpr = $input_expr{$type_kind{$subtype}};
927 $subexpr =~ s/ntype/subtype/g;
928 $subexpr =~ s/\$arg/ST(ix_$var)/g;
929 $subexpr =~ s/\n\t/\n\t\t/g;
930 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
931 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
932 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
934 if (defined($defaults{$var})) {
935 $expr =~ s/(\t+)/$1 /g;
937 eval qq/print "\\t$var;\\n"/;
938 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
939 } elsif ($expr !~ /^\t\$var =/) {
940 eval qq/print "\\t$var;\\n"/;
941 $deferred .= eval qq/"\\n$expr;\\n"/;
943 eval qq/print "$expr;\\n"/;
947 sub generate_output {
948 local($type, $num, $var) = @_;
949 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
950 local($argoff) = $num - 1;
953 $type = TidyType($type) ;
954 if ($type =~ /^array\(([^,]*),(.*)\)/) {
955 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
957 blurt("Error: '$type' not in typemap"), return
958 unless defined($type_kind{$type});
959 blurt("Error: No OUTPUT definition for type '$type' found"), return
960 unless defined $output_expr{$type_kind{$type}} ;
961 ($ntype = $type) =~ s/\s*\*/Ptr/g;
963 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
964 $expr = $output_expr{$type_kind{$type}};
965 if ($expr =~ /DO_ARRAY_ELEM/) {
966 blurt("Error: '$subtype' not in typemap"), return
967 unless defined($type_kind{$subtype});
968 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
969 unless defined $output_expr{$type_kind{$subtype}} ;
970 $subexpr = $output_expr{$type_kind{$subtype}};
971 $subexpr =~ s/ntype/subtype/g;
972 $subexpr =~ s/\$arg/ST(ix_$var)/g;
973 $subexpr =~ s/\$var/${var}[ix_$var]/g;
974 $subexpr =~ s/\n\t/\n\t\t/g;
975 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
976 eval "print qq\a$expr\a";
978 elsif ($var eq 'RETVAL') {
979 if ($expr =~ /^\t\$arg = /) {
980 eval "print qq\a$expr\a";
981 print "\tsv_2mortal(ST(0));\n";
984 print "\tST(0) = sv_newmortal();\n";
985 eval "print qq\a$expr\a";
988 elsif ($arg =~ /^ST\(\d+\)$/) {
989 eval "print qq\a$expr\a";
998 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1004 # If this is VMS, the exit status has meaning to the shell, so we
1005 # use a predictable value (SS$_Abort) rather than an arbitrary
1007 exit ($Is_VMS ? 44 : $errors) ;