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.
59 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
61 SWITCH: while ($ARGV[0] =~ s/^-//) {
63 $spat = shift, next SWITCH if $flag eq 's';
64 $cplusplus = 1, next SWITCH if $flag eq 'C++';
65 $except = 1, next SWITCH if $flag eq 'except';
66 push(@tm,shift), next SWITCH if $flag eq 'typemap';
69 @ARGV == 1 or die $usage;
71 # Check for error message from VMS
72 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
73 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
74 or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
75 or ($dir, $filename) = ('.', $ARGV[0]);
78 $typemap = shift @ARGV;
79 foreach $typemap (@tm) {
80 die "Can't find $typemap in $pwd\n" unless -r $typemap;
82 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
83 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
85 foreach $typemap (@tm) {
86 open(TYPEMAP, $typemap) || next;
91 if (/^INPUT\s*$/) { $mode = Input, next }
92 if (/^OUTPUT\s*$/) { $mode = Output, next }
93 if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
94 if ($mode eq Typemap) {
96 ($typename, $kind) = split(/\t+/, $_, 2);
97 $type_kind{$typename} = $kind if $kind ne '';
99 elsif ($mode eq Input) {
105 $input_expr{$_} = '';
106 $current = \$input_expr{$_};
115 $output_expr{$_} = '';
116 $current = \$output_expr{$_};
123 foreach $key (keys %input_expr) {
124 $input_expr{$key} =~ s/\n+$//;
135 open(F, $filename) || die "cannot open $filename\n";
138 last if ($Module, $foo, $Package, $foo1, $Prefix) =
139 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
148 if ($lastline ne "") {
150 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
156 ($Module_cname = $Module) =~ s/\W/_/g;
157 ($Packid = $Package) =~ s/:/_/g;
158 $Packprefix = $Package;
159 $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
163 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
166 push(@line, $_) if $_ ne "";
169 push(@line, $lastline);
174 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
176 if (/^\S/ && @line && $line[-1] eq "") {
184 pop(@line) while @line && $line[-1] =~ /^\s*$/;
186 $PPCODE = grep(/PPCODE:/, @line);
190 while (&fetch_para) {
191 # initialize info arrays
200 # extract return type, function name and arguments
201 $ret_type = shift(@line);
202 if ($ret_type =~ /^BOOT:/) {
203 push (@BootCode, @line, "", "") ;
206 if ($ret_type =~ /^static\s+(.*)$/) {
210 $func_header = shift(@line);
211 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
212 if ($func_name =~ /(.*)::(.*)/) {
216 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
217 push(@Func_name, "${Packid}_$func_name");
218 push(@Func_pname, $pname);
219 @args = split(/\s*,\s*/, $orig_args);
220 if (defined($class)) {
221 if (defined($static)) {
222 unshift(@args, "CLASS");
223 $orig_args = "CLASS, $orig_args";
224 $orig_args =~ s/^CLASS, $/CLASS/;
227 unshift(@args, "THIS");
228 $orig_args = "THIS, $orig_args";
229 $orig_args =~ s/^THIS, $/THIS/;
232 $orig_args =~ s/"/\\"/g;
233 $min_args = $num_args = @args;
234 foreach $i (0..$num_args-1) {
235 if ($args[$i] =~ s/\.\.\.//) {
238 if ($args[i] eq '' && $i == $num_args - 1) {
243 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
246 $defaults{$args[$i]} = $2;
247 $defaults{$args[$i]} =~ s/"/\\"/g;
250 if (defined($class)) {
251 $func_args = join(", ", @args[1..$#args]);
253 $func_args = join(", ", @args);
255 @args_match{@args} = 1..@args;
257 # print function header
259 #XS(XS_${Packid}_$func_name)
264 $cond = qq(items < $min_args);
266 elsif ($min_args == $num_args) {
267 $cond = qq(items != $min_args);
270 $cond = qq(items < $min_args || items > $num_args);
273 print Q<<"EOF" if $except;
280 # croak("Usage: $pname($orig_args)");
284 print Q<<"EOF" if $PPCODE;
288 # Now do a block of some sort.
295 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
296 $cond = shift(@line);
298 print " if ($cond)\n";
300 elsif ($cond ne '') {
301 print " else if ($cond)\n";
320 # do initialization of input variables
326 last if /^\s*NOT_IMPLEMENTED_YET/;
327 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
328 ($var_type, $var_name, $var_init) =
329 /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
330 # Catch common errors. More error checking required here.
331 blurt("Error: no tab in $pname argument declaration '$_'\n")
332 unless (m/\S+\s*\t\s*\S+/);
333 # catch C style argument declaration (this could be made alowable syntax)
334 warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
335 if ($var_name =~ s/;//g); # eg SV *<tab>name;
336 # catch many errors similar to: SV<tab>* name
337 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
338 unless ($var_name =~ m/^&?\w+$/);
339 if ($var_name =~ /^&/) {
341 $var_addr{$var_name} = 1;
343 $thisdone |= $var_name eq "THIS";
344 $retvaldone |= $var_name eq "RETVAL";
345 $var_types{$var_name} = $var_type;
346 print "\t" . &map_type($var_type);
347 $var_num = $args_match{$var_name};
348 if ($var_addr{$var_name}) {
349 $func_args =~ s/\b($var_name)\b/&\1/;
351 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
352 if ($var_init !~ /^\s*$/) {
353 &output_init($var_type, $var_num,
354 "$var_name $var_init");
356 # generate initialization code
357 &generate_init($var_type, $var_num, $var_name);
362 print "\t$var_name;\n";
365 if (!$thisdone && defined($class)) {
366 if (defined($static)) {
368 $var_types{"CLASS"} = "char *";
369 &generate_init("char *", 1, "CLASS");
373 $var_types{"THIS"} = "$class *";
374 &generate_init("$class *", 1, "THIS");
379 if (/^\s*NOT_IMPLEMENTED_YET/) {
380 print "\ncroak(\"$pname: not implemented yet\");\n";
382 if ($ret_type ne "void") {
383 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
385 $args_match{"RETVAL"} = 0;
386 $var_types{"RETVAL"} = $ret_type;
392 die "PPCODE must be last thing"
393 if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
396 print "\tPUTBACK;\n\treturn;\n";
397 } elsif (/^\s*CODE:/) {
401 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
404 } elsif ($func_name eq "DESTROY") {
407 print "delete THIS;\n"
411 if ($ret_type ne "void") {
414 if (defined($static)) {
415 if ($func_name =~ /^new/) {
416 $func_name = "$class";
421 } elsif (defined($class)) {
424 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
427 print "$func_name($func_args);\n";
428 &generate_output($ret_type, 0, "RETVAL")
429 unless $ret_type eq "void";
433 # do output variables
434 if (/^\s*OUTPUT\s*:/) {
437 last if /^\s*CLEANUP\s*:/;
439 ($outarg, $outcode) = split(/\t+/);
441 print "\t$outcode\n";
443 die "$outarg not an argument"
444 unless defined($args_match{$outarg});
445 $var_num = $args_match{$outarg};
446 &generate_output($var_types{$outarg}, $var_num,
452 if (/^\s*CLEANUP\s*:/) {
455 last if /^\s*CASE\s*:/;
459 # print function trailer
465 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
474 if (/^\s*CASE\s*:/) {
479 print Q<<EOF if $except;
484 print Q<<EOF unless $PPCODE;
494 # print initialization routine
495 print qq/extern "C"\n/ if $cplusplus;
497 #XS(boot_$Module_cname)
500 # char* file = __FILE__;
505 $pname = shift(@Func_pname);
506 print " newXS(\"$pname\", XS_$_, file);\n";
511 print "\n /* Initialisation Section */\n\n" ;
512 print grep (s/$/\n/, @BootCode) ;
513 print " /* End of Initialisation Section */\n\n" ;
516 print " ST(0) = &sv_yes;\n";
517 print " XSRETURN(1);\n";
521 local($type, $num, $init) = @_;
522 local($arg) = "ST(" . ($num - 1) . ")";
524 eval qq/print " $init\\\n"/;
527 sub blurt { warn @_; $errors++ }
530 local($type, $num, $var) = @_;
531 local($arg) = "ST(" . ($num - 1) . ")";
532 local($argoff) = $num - 1;
536 blurt("'$type' not in typemap"), return unless defined($type_kind{$type});
537 ($ntype = $type) =~ s/\s*\*/Ptr/g;
539 $subtype =~ s/Ptr$//;
540 $subtype =~ s/Array$//;
541 $tk = $type_kind{$type};
542 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
544 $expr = $input_expr{$tk};
545 if ($expr =~ /DO_ARRAY_ELEM/) {
546 $subexpr = $input_expr{$type_kind{$subtype}};
547 $subexpr =~ s/ntype/subtype/g;
548 $subexpr =~ s/\$arg/ST(ix_$var)/g;
549 $subexpr =~ s/\n\t/\n\t\t/g;
550 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
551 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
552 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
554 if (defined($defaults{$var})) {
555 $expr =~ s/(\t+)/$1 /g;
557 eval qq/print "\\t$var;\\n"/;
558 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
559 } elsif ($expr !~ /^\t\$var =/) {
560 eval qq/print "\\t$var;\\n"/;
561 $deferred .= eval qq/"\\n$expr;\\n"/;
563 eval qq/print "$expr;\\n"/;
567 sub generate_output {
568 local($type, $num, $var) = @_;
569 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
570 local($argoff) = $num - 1;
573 if ($type =~ /^array\(([^,]*),(.*)\)/) {
574 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
576 blurt("'$type' not in typemap"), return
577 unless defined($type_kind{$type});
578 ($ntype = $type) =~ s/\s*\*/Ptr/g;
581 $subtype =~ s/Ptr$//;
582 $subtype =~ s/Array$//;
583 $expr = $output_expr{$type_kind{$type}};
584 if ($expr =~ /DO_ARRAY_ELEM/) {
585 $subexpr = $output_expr{$type_kind{$subtype}};
586 $subexpr =~ s/ntype/subtype/g;
587 $subexpr =~ s/\$arg/ST(ix_$var)/g;
588 $subexpr =~ s/\$var/${var}[ix_$var]/g;
589 $subexpr =~ s/\n\t/\n\t\t/g;
590 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
591 eval "print qq\a$expr\a";
593 elsif ($var eq 'RETVAL') {
594 if ($expr =~ /^\t\$arg = /) {
595 eval "print qq\a$expr\a";
596 print "\tsv_2mortal(ST(0));\n";
599 print "\tST(0) = sv_newmortal();\n";
600 eval "print qq\a$expr\a";
603 elsif ($arg =~ /^ST\(\d+\)$/) {
604 eval "print qq\a$expr\a";
606 elsif ($arg =~ /^ST\(\d+\)$/) {
607 eval "print qq\a$expr\a";
609 elsif ($arg =~ /^ST\(\d+\)$/) {
610 eval "print qq\a$expr\a";
619 if ($type =~ /^array\(([^,]*),(.*)\)/) {
626 # If this is VMS, the exit status has meaning to the shell, so we
627 # use a predictable value (SS$_Abort) rather than an arbitrary
629 exit $Is_VMS ? 44 : $errors;