5 xsubpp - compiler to convert Perl XS code into C code
9 B<xsubpp> [B<-C++>] [B<-except>] [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.
47 No environment variables are used.
53 =head1 MODIFICATION HISTORY
57 I<xsubpp> as released with Perl 5.000
61 I<xsubpp> as released with Perl 5.001
65 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.
71 Added I<xsubpp> version number for the first time. As previous releases
72 of I<xsubpp> did not have a formal version number, a numbering scheme
73 has been applied retrospectively.
77 If OUTPUT: is being used to specify output parameters and RETVAL is
78 also to be returned, it is now no longer necessary for the user to
79 ensure that RETVAL is specified last.
83 The I<xsubpp> version number, the .xs filename and a time stamp are
84 written to the generated .c file as a comment.
88 When I<xsubpp> is parsing the definition of both the input parameters
89 and the OUTPUT parameters, any duplicate definitions will be noted and
94 I<xsubpp> is slightly more forgiving with extra whitespace.
100 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.
106 More whitespace restrictions have been relaxed. In particular some
107 cases where a tab character was used to delimit fields has been
108 removed. In these cases any whitespace will now suffice.
110 The specific places where changes have been made are in the TYPEMAP
111 section of a typemap file and the input and OUTPUT: parameter
112 declarations sections in a .xs file.
116 More error checking added.
118 Before processing each typemap file I<xsubpp> now checks that it is a
119 text file. If not an warning will be displayed. In addition, a warning
120 will be displayed if it is not possible to open the typemap file.
122 In the TYPEMAP section of a typemap file, an error will be raised if
123 the line does not have 2 columns.
125 When parsing input parameter declarations check that there is at least
126 a type and name pair.
132 When parsing the OUTPUT arguments check that they are all present in
133 the corresponding input argument definitions.
142 $XSUBPP_version = "1.4" ;
144 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
146 SWITCH: while ($ARGV[0] =~ s/^-//) {
148 $spat = shift, next SWITCH if $flag eq 's';
149 $cplusplus = 1, next SWITCH if $flag eq 'C++';
150 $except = 1, next SWITCH if $flag eq 'except';
151 push(@tm,shift), next SWITCH if $flag eq 'typemap';
154 @ARGV == 1 or die $usage;
156 # Check for error message from VMS
157 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
158 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
159 or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
160 or ($dir, $filename) = ('.', $ARGV[0]);
165 $_[0] =~ s/^\s+|\s+$//go ;
172 # rationalise any '*' by joining them into bunches and removing whitespace
175 # change multiple whitespace into a single space
178 # trim leading & trailing whitespace
184 $typemap = shift @ARGV;
185 foreach $typemap (@tm) {
186 die "Can't find $typemap in $pwd\n" unless -r $typemap;
188 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
189 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
191 foreach $typemap (@tm) {
192 next unless -e $typemap ;
193 # skip directories, binary files etc.
194 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
196 open(TYPEMAP, $typemap)
197 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
202 if (/^INPUT\s*$/) { $mode = Input, next }
203 if (/^OUTPUT\s*$/) { $mode = Output, next }
204 if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
205 if ($mode eq Typemap) {
209 # skip blank lines and comment lines
210 next if /^$/ or /^#/ ;
211 my @words = split (' ') ;
212 blurt("Error: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next
214 my $kind = pop @words ;
215 TrimWhitespace($kind) ;
216 $type_kind{TidyType("@words")} = $kind ;
218 elsif ($mode eq Input) {
224 $input_expr{$_} = '';
225 $current = \$input_expr{$_};
234 $output_expr{$_} = '';
235 $current = \$output_expr{$_};
242 foreach $key (keys %input_expr) {
243 $input_expr{$key} =~ s/\n+$//;
254 # Identify the version of xsubpp used
255 $TimeStamp = localtime ;
258 * This file was generated automatically by xsubpp version $XSUBPP_version
259 * from $filename on $TimeStamp
266 open(F, $filename) or die "cannot open $filename: $!\n";
269 last if ($Module, $foo, $Package, $foo1, $Prefix) =
270 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
279 if ($lastline ne "") {
281 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
287 ($Module_cname = $Module) =~ s/\W/_/g;
288 ($Packid = $Package) =~ s/:/_/g;
289 $Packprefix = $Package;
290 $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
294 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
297 push(@line, $_) if $_ ne "";
300 push(@line, $lastline);
305 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
307 if (/^\S/ && @line && $line[-1] eq "") {
315 pop(@line) while @line && $line[-1] =~ /^\s*$/;
317 $PPCODE = grep(/PPCODE:/, @line);
321 while (&fetch_para) {
322 # initialize info arrays
333 # extract return type, function name and arguments
334 $ret_type = TidyType(shift(@line));
335 if ($ret_type =~ /^BOOT:/) {
336 push (@BootCode, @line, "", "") ;
339 if ($ret_type =~ /^static\s+(.*)$/) {
343 $func_header = shift(@line);
344 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
345 if ($func_name =~ /(.*)::(.*)/) {
349 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
350 push(@Func_name, "${Packid}_$func_name");
351 push(@Func_pname, $pname);
352 @args = split(/\s*,\s*/, $orig_args);
353 if (defined($class)) {
354 if (defined($static)) {
355 unshift(@args, "CLASS");
356 $orig_args = "CLASS, $orig_args";
357 $orig_args =~ s/^CLASS, $/CLASS/;
360 unshift(@args, "THIS");
361 $orig_args = "THIS, $orig_args";
362 $orig_args =~ s/^THIS, $/THIS/;
365 $orig_args =~ s/"/\\"/g;
366 $min_args = $num_args = @args;
367 foreach $i (0..$num_args-1) {
368 if ($args[$i] =~ s/\.\.\.//) {
371 if ($args[i] eq '' && $i == $num_args - 1) {
376 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
379 $defaults{$args[$i]} = $2;
380 $defaults{$args[$i]} =~ s/"/\\"/g;
383 if (defined($class)) {
384 $func_args = join(", ", @args[1..$#args]);
386 $func_args = join(", ", @args);
388 @args_match{@args} = 1..@args;
390 # print function header
392 #XS(XS_${Packid}_$func_name)
397 $cond = qq(items < $min_args);
399 elsif ($min_args == $num_args) {
400 $cond = qq(items != $min_args);
403 $cond = qq(items < $min_args || items > $num_args);
406 print Q<<"EOF" if $except;
413 # croak("Usage: $pname($orig_args)");
417 print Q<<"EOF" if $PPCODE;
421 # Now do a block of some sort.
428 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
429 $cond = shift(@line);
431 print " if ($cond)\n";
433 elsif ($cond ne '') {
434 print " else if ($cond)\n";
453 # do initialization of input variables
459 last if /^\s*NOT_IMPLEMENTED_YET/;
460 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
466 # check for optional initialisation code
467 my $var_init = $1 if s/\s*(=.*)$// ;
469 my @words = split (' ') ;
470 blurt("Error: invalid argument declaration '$line'"), next
472 my $var_name = pop @words ;
473 my $var_type = "@words" ;
475 # catch C style argument declaration (this could be made alowable syntax)
476 warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
477 if ($var_name =~ s/;//g); # eg SV *<tab>name;
478 # catch many errors similar to: SV<tab>* name
479 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
480 unless ($var_name =~ m/^&?\w+$/);
481 if ($var_name =~ /^&/) {
483 $var_addr{$var_name} = 1;
486 # Check for duplicate definitions
487 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
488 if $arg_list{$var_name} ++ ;
490 $thisdone |= $var_name eq "THIS";
491 $retvaldone |= $var_name eq "RETVAL";
492 $var_types{$var_name} = $var_type;
493 print "\t" . &map_type($var_type);
494 $var_num = $args_match{$var_name};
495 if ($var_addr{$var_name}) {
496 $func_args =~ s/\b($var_name)\b/&\1/;
498 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
499 if ($var_init !~ /^\s*$/) {
500 &output_init($var_type, $var_num,
501 "$var_name $var_init");
503 # generate initialization code
504 &generate_init($var_type, $var_num, $var_name);
509 print "\t$var_name;\n";
512 if (!$thisdone && defined($class)) {
513 if (defined($static)) {
515 $var_types{"CLASS"} = "char *";
516 &generate_init("char *", 1, "CLASS");
520 $var_types{"THIS"} = "$class *";
521 &generate_init("$class *", 1, "THIS");
526 if (/^\s*NOT_IMPLEMENTED_YET/) {
527 print "\ncroak(\"$pname: not implemented yet\");\n";
529 if ($ret_type ne "void") {
530 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
532 $args_match{"RETVAL"} = 0;
533 $var_types{"RETVAL"} = $ret_type;
539 die "PPCODE must be last thing"
540 if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
543 print "\tPUTBACK;\n\treturn;\n";
544 } elsif (/^\s*CODE:/) {
548 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
551 } elsif ($func_name eq "DESTROY") {
554 print "delete THIS;\n"
558 if ($ret_type ne "void") {
561 if (defined($static)) {
562 if ($func_name =~ /^new/) {
563 $func_name = "$class";
568 } elsif (defined($class)) {
571 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
574 print "$func_name($func_args);\n";
576 unless $ret_type eq "void";
580 # do output variables
581 if (/^\s*OUTPUT\s*:/) {
586 last if /^\s*CLEANUP\s*:/;
589 my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
590 if (!$gotRETVAL and $outarg eq 'RETVAL') {
591 # deal with RETVAL last
594 undef ($wantRETVAL) ;
597 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
598 if $outargs{$outarg} ++ ;
599 blurt ("Error: OUTPUT $outarg not an argument"), next
600 unless defined($args_match{$outarg});
601 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
602 unless defined $var_types{$outarg} ;
604 print "\t$outcode\n";
606 $var_num = $args_match{$outarg};
607 &generate_output($var_types{$outarg}, $var_num,
613 # all OUTPUT done, so now push the return value on the stack
614 &generate_output($ret_type, 0, "RETVAL")
618 if (/^\s*CLEANUP\s*:/) {
621 last if /^\s*CASE\s*:/;
625 # print function trailer
631 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
640 if (/^\s*CASE\s*:/) {
645 print Q<<EOF if $except;
650 print Q<<EOF unless $PPCODE;
660 # print initialization routine
661 print qq/extern "C"\n/ if $cplusplus;
663 #XS(boot_$Module_cname)
666 # char* file = __FILE__;
671 $pname = shift(@Func_pname);
672 print " newXS(\"$pname\", XS_$_, file);\n";
677 print "\n /* Initialisation Section */\n\n" ;
678 print grep (s/$/\n/, @BootCode) ;
679 print " /* End of Initialisation Section */\n\n" ;
682 print " ST(0) = &sv_yes;\n";
683 print " XSRETURN(1);\n";
687 local($type, $num, $init) = @_;
688 local($arg) = "ST(" . ($num - 1) . ")";
690 eval qq/print " $init\\\n"/;
693 sub blurt { warn @_; $errors++ }
696 local($type, $num, $var) = @_;
697 local($arg) = "ST(" . ($num - 1) . ")";
698 local($argoff) = $num - 1;
702 $type = TidyType($type) ;
703 blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type});
704 ($ntype = $type) =~ s/\s*\*/Ptr/g;
706 $subtype =~ s/Ptr$//;
707 $subtype =~ s/Array$//;
708 $tk = $type_kind{$type};
709 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
711 $expr = $input_expr{$tk};
712 if ($expr =~ /DO_ARRAY_ELEM/) {
713 $subexpr = $input_expr{$type_kind{$subtype}};
714 $subexpr =~ s/ntype/subtype/g;
715 $subexpr =~ s/\$arg/ST(ix_$var)/g;
716 $subexpr =~ s/\n\t/\n\t\t/g;
717 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
718 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
719 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
721 if (defined($defaults{$var})) {
722 $expr =~ s/(\t+)/$1 /g;
724 eval qq/print "\\t$var;\\n"/;
725 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
726 } elsif ($expr !~ /^\t\$var =/) {
727 eval qq/print "\\t$var;\\n"/;
728 $deferred .= eval qq/"\\n$expr;\\n"/;
730 eval qq/print "$expr;\\n"/;
734 sub generate_output {
735 local($type, $num, $var) = @_;
736 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
737 local($argoff) = $num - 1;
740 $type = TidyType($type) ;
741 if ($type =~ /^array\(([^,]*),(.*)\)/) {
742 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
744 blurt("Error: '$type' not in typemap"), return
745 unless defined($type_kind{$type});
746 ($ntype = $type) =~ s/\s*\*/Ptr/g;
749 $subtype =~ s/Ptr$//;
750 $subtype =~ s/Array$//;
751 $expr = $output_expr{$type_kind{$type}};
752 if ($expr =~ /DO_ARRAY_ELEM/) {
753 $subexpr = $output_expr{$type_kind{$subtype}};
754 $subexpr =~ s/ntype/subtype/g;
755 $subexpr =~ s/\$arg/ST(ix_$var)/g;
756 $subexpr =~ s/\$var/${var}[ix_$var]/g;
757 $subexpr =~ s/\n\t/\n\t\t/g;
758 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
759 eval "print qq\a$expr\a";
761 elsif ($var eq 'RETVAL') {
762 if ($expr =~ /^\t\$arg = /) {
763 eval "print qq\a$expr\a";
764 print "\tsv_2mortal(ST(0));\n";
767 print "\tST(0) = sv_newmortal();\n";
768 eval "print qq\a$expr\a";
771 elsif ($arg =~ /^ST\(\d+\)$/) {
772 eval "print qq\a$expr\a";
774 elsif ($arg =~ /^ST\(\d+\)$/) {
775 eval "print qq\a$expr\a";
777 elsif ($arg =~ /^ST\(\d+\)$/) {
778 eval "print qq\a$expr\a";
787 if ($type =~ /^array\(([^,]*),(.*)\)/) {
794 # If this is VMS, the exit status has meaning to the shell, so we
795 # use a predictable value (SS$_Abort) rather than an arbitrary
797 exit $Is_VMS ? 44 : $errors;