ext/xsubpp

   1 #!./miniperl
   2 # $Header$
   3
   4 $usage = "Usage: xsubpp [-ansi] [-C++] [-except] [-tm typemap] file.xs\n";
   5
   6 SWITCH: while ($ARGV[0] =~ s/^-//) {
   7     $flag = shift @ARGV;
   8     $ansiflag = 1,      next SWITCH     if $flag eq 'ansi';
   9     $spat = shift,      next SWITCH     if $flag eq 's';
  10     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
  11     $except = 1,        next SWITCH     if $flag eq 'except';
  12     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
  13     die $usage;
  14 }
  15 @ARGV == 1 or die $usage;
  16 chop($pwd = `pwd`);
  17 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
  18         or ($dir, $filename) = ('.', $ARGV[0]);
  19 chdir($dir);
  20
  21 $typemap = shift @ARGV;
  22 foreach $typemap (@tm) {
  23     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  24 }
  25 unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
  26 foreach $typemap (@tm) {
  27     open(TYPEMAP, $typemap) || next;
  28     $mode = Typemap;
  29     $current = \$junk;
  30     while (<TYPEMAP>) {
  31         next if /^#/;
  32         if (/^INPUT\s*$/) { $mode = Input, next }
  33         if (/^OUTPUT\s*$/) { $mode = Output, next }
  34         if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
  35         if ($mode eq Typemap) {
  36             chop;
  37             ($typename, $kind) = split(/\t+/, $_, 2);
  38             $type_kind{$typename} = $kind if $kind ne '';
  39         }
  40         elsif ($mode eq Input) {
  41             if (/^\s/) {
  42                 $$current .= $_;
  43             }
  44             else {
  45                 s/\s*$//;
  46 #               $input_expr{$_} = '';
  47                 $current = \$input_expr{$_};
  48             }
  49         }
  50         else {
  51             if (/^\s/) {
  52                 $$current .= $_;
  53             }
  54             else {
  55                 s/\s*$//;
  56 #               $output_expr{$_} = '';
  57                 $current = \$output_expr{$_};
  58             }
  59         }
  60     }
  61     close(TYPEMAP);
  62 }
  63
  64 foreach $key (keys %input_expr) {
  65     $input_expr{$key} =~ s/\n+$//;
  66 }
  67
  68 sub Q {
  69     local $text = shift;
  70     $text =~ tr/#//d;
  71     $text =~ s/\[\[/{/g;
  72     $text =~ s/\]\]/}/g;
  73     $text;
  74 }
  75
  76 open(F, $filename) || die "cannot open $filename\n";
  77
  78 while (<F>) {
  79         last if ($Module, $foo, $Package, $foo1, $Prefix) =
  80                 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?$/;
  81         print $_;
  82 }
  83 exit 0 if $_ eq "";
  84 $lastline = $_;
  85
  86 sub fetch_para {
  87     # parse paragraph
  88     @line = ();
  89     if ($lastline ne "") {
  90         if ($lastline =~
  91     /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?$/) {
  92             $Module = $1;
  93             $foo = $2;
  94             $Package = $3;
  95             $foo1 = $4;
  96             $Prefix = $5;
  97             ($Packid = $Package) =~ s/:/_/g;
  98             $Packprefix = $Package;
  99             $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
 100             while (<F>) {
 101                 chop;
 102                 last if /^\S/;
 103             }
 104             push(@line, $_) if $_ ne "";
 105         }
 106         else {
 107             push(@line, $lastline);
 108         }
 109         $lastline = "";
 110         while (<F>) {
 111             next if /^#/ && !/^#(if|ifdef|else|elif|endif|define|undef)\b/;
 112             chop;
 113             if (/^\S/ && @line && $line[-1] eq "") {
 114                 $lastline = $_;
 115                 last;
 116             }
 117             else {
 118                 push(@line, $_);
 119             }
 120         }
 121         pop(@line) while @line && $line[-1] eq "";
 122     }
 123     scalar @line;
 124 }
 125
 126 while (&fetch_para) {
 127     # initialize info arrays
 128     undef(%args_match);
 129     undef(%var_types);
 130     undef(%var_addr);
 131     undef(%defaults);
 132     undef($class);
 133     undef($static);
 134     undef($elipsis);
 135
 136     # extract return type, function name and arguments
 137     $ret_type = shift(@line);
 138     if ($ret_type =~ /^static\s+(.*)$/) {
 139             $static = 1;
 140             $ret_type = $1;
 141     }
 142     $func_header = shift(@line);
 143     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 144     if ($func_name =~ /(.*)::(.*)/) {
 145             $class = $1;
 146             $func_name = $2;
 147     }
 148     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 149     push(@Func_name, "${Packid}_$func_name");
 150     push(@Func_pname, $pname);
 151     @args = split(/\s*,\s*/, $orig_args);
 152     if (defined($class) && !defined($static)) {
 153             unshift(@args, "THIS");
 154             $orig_args = "THIS, $orig_args";
 155             $orig_args =~ s/^THIS, $/THIS/;
 156     }
 157     $orig_args =~ s/"/\\"/g;
 158     $min_args = $num_args = @args;
 159     foreach $i (0..$num_args-1) {
 160             if ($args[$i] =~ s/\.\.\.//) {
 161                     $elipsis = 1;
 162                     $min_args--;
 163                     if ($args[i] eq '' && $i == $num_args - 1) {
 164                         pop(@args);
 165                         last;
 166                     }
 167             }
 168             if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 169                     $min_args--;
 170                     $args[$i] = $1;
 171                     $defaults{$args[$i]} = $2;
 172                     $defaults{$args[$i]} =~ s/"/\\"/g;
 173             }
 174     }
 175     if (defined($class) && !defined($static)) {
 176             $func_args = join(", ", @args[1..$#args]);
 177     } else {
 178             $func_args = join(", ", @args);
 179     }
 180     @args_match{@args} = 1..@args;
 181
 182     # print function header
 183     if ($ansiflag) {
 184         print Q<<"EOF";
 185 #static int
 186 #XS_${Packid}_$func_name(int, int ax, int items)
 187 #[[
 188 EOF
 189     }
 190     else {
 191         print Q<<"EOF";
 192 #static int
 193 #XS_${Packid}_$func_name(ix, ax, items)
 194 #register int ix;
 195 #register int ax;
 196 #register int items;
 197 #[[
 198 EOF
 199     }
 200     if ($elipsis) {
 201         $cond = qq(items < $min_args);
 202     }
 203     elsif ($min_args == $num_args) {
 204         $cond = qq(items != $min_args);
 205     }
 206     else {
 207         $cond = qq(items < $min_args || items > $num_args);
 208     }
 209
 210     print Q<<"EOF" if $except;
 211 #    char errbuf[1024];
 212 #    *errbuf = '\0';
 213 EOF
 214
 215     print Q<<"EOF";
 216 #    if ($cond) {
 217 #       croak("Usage: $pname($orig_args)");
 218 #    }
 219 EOF
 220
 221     # Now do a block of some sort.
 222
 223     $condnum = 0;
 224     if (!@line) {
 225         @line = "CLEANUP:";
 226     }
 227     while (@line) {
 228         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
 229             $cond = shift(@line);
 230             if ($condnum == 0) {
 231                 print "    if ($cond)\n";
 232             }
 233             elsif ($cond ne '') {
 234                 print "    else if ($cond)\n";
 235             }
 236             else {
 237                 print "    else\n";
 238             }
 239             $condnum++;
 240         }
 241
 242         if ($except) {
 243             print Q<<"EOF";
 244 #    TRY [[
 245 EOF
 246         }
 247         else {
 248             print Q<<"EOF";
 249 #    [[
 250 EOF
 251         }
 252
 253         # do initialization of input variables
 254         $thisdone = 0;
 255         $retvaldone = 0;
 256         $deferred = "";
 257         while (@line) {
 258                 $_ = shift(@line);
 259                 last if /^\s*NOT_IMPLEMENTED_YET/;
 260                 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 261                 ($var_type, $var_name, $var_init) =
 262                     /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
 263                 if ($var_name =~ /^&/) {
 264                         $var_name =~ s/^&//;
 265                         $var_addr{$var_name} = 1;
 266                 }
 267                 $thisdone |= $var_name eq "THIS";
 268                 $retvaldone |= $var_name eq "RETVAL";
 269                 $var_types{$var_name} = $var_type;
 270                 print "\t" . &map_type($var_type);
 271                 $var_num = $args_match{$var_name};
 272                 if ($var_addr{$var_name}) {
 273                         $func_args =~ s/\b($var_name)\b/&\1/;
 274                 }
 275                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 276                         if ($var_init !~ /^\s*$/) {
 277                                 &output_init($var_type, $var_num,
 278                                     "$var_name $var_init");
 279                         } elsif ($var_num) {
 280                                 # generate initialization code
 281                                 &generate_init($var_type, $var_num, $var_name);
 282                         } else {
 283                                 print ";\n";
 284                         }
 285                 } else {
 286                         print "\t$var_name;\n";
 287                 }
 288         }
 289         if (!$thisdone && defined($class) && !defined($static)) {
 290                 print "\t$class *";
 291                 $var_types{"THIS"} = "$class *";
 292                 &generate_init("$class *", 1, "THIS");
 293         }
 294
 295         # do code
 296         if (/^\s*NOT_IMPLEMENTED_YET/) {
 297                 print "\ncroak(\"$pname: not implemented yet\");\n";
 298         } else {
 299                 if ($ret_type ne "void") {
 300                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 301                                 if !$retvaldone;
 302                         $args_match{"RETVAL"} = 0;
 303                         $var_types{"RETVAL"} = $ret_type;
 304                 }
 305                 if (/^\s*PPCODE:/) {
 306                         print "\tdSP;\n";
 307                         print $deferred;
 308                         while (@line) {
 309                                 $_ = shift(@line);
 310                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 311                                 print "$_\n";
 312                         }
 313                         print "\tax = sp - stack_base;\n";
 314                 } elsif (/^\s*CODE:/) {
 315                         print $deferred;
 316                         while (@line) {
 317                                 $_ = shift(@line);
 318                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 319                                 print "$_\n";
 320                         }
 321                 } else {
 322                         print $deferred;
 323                         print "\n\t";
 324                         if ($ret_type ne "void") {
 325                                 print "RETVAL = ";
 326                         }
 327                         if (defined($static)) {
 328                                 print "$class::";
 329                         } elsif (defined($class)) {
 330                                 print "THIS->";
 331                         }
 332                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
 333                                 $func_name = $2;
 334                         }
 335                         print "$func_name($func_args);\n";
 336                         &generate_output($ret_type, 0, "RETVAL")
 337                             unless $ret_type eq "void";
 338                 }
 339         }
 340
 341         # do output variables
 342         if (/^\s*OUTPUT\s*:/) {
 343                 while (@line) {
 344                         $_ = shift(@line);
 345                         last if /^\s*CLEANUP\s*:/;
 346                         s/^\s+//;
 347                         ($outarg, $outcode) = split(/\t+/);
 348                         if ($outcode) {
 349                         print "\t$outcode\n";
 350                         } else {
 351                                 die "$outarg not an argument"
 352                                     unless defined($args_match{$outarg});
 353                                 $var_num = $args_match{$outarg};
 354                                 &generate_output($var_types{$outarg}, $var_num,
 355                                     $outarg);
 356                         }
 357                 }
 358         }
 359         # do cleanup
 360         if (/^\s*CLEANUP\s*:/) {
 361             while (@line) {
 362                     $_ = shift(@line);
 363                     last if /^\s*CASE\s*:/;
 364                     print "$_\n";
 365             }
 366         }
 367         # print function trailer
 368         if ($except) {
 369             print Q<<EOF;
 370 #    ]]
 371 #    BEGHANDLERS
 372 #    CATCHALL
 373 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 374 #    ENDHANDLERS
 375 EOF
 376         }
 377         else {
 378             print Q<<EOF;
 379 #    ]]
 380 EOF
 381         }
 382         if (/^\s*CASE\s*:/) {
 383             unshift(@line, $_);
 384         }
 385     }
 386     print Q<<EOF if $except;
 387 #    if (errbuf[0])
 388 #       croak(errbuf);
 389 EOF
 390     print Q<<EOF;
 391 #    return ax;
 392 #]]
 393 #
 394 EOF
 395 }
 396
 397 # print initialization routine
 398 print qq/extern "C"\n/ if $cplusplus;
 399 print Q<<"EOF";
 400 #int boot_$Module(ix,ax,items)
 401 #int ix;
 402 #int ax;
 403 #int items;
 404 #[[
 405 #    char* file = __FILE__;
 406 #
 407 EOF
 408
 409 for (@Func_name) {
 410     $pname = shift(@Func_pname);
 411     print "    newXSUB(\"$pname\", 0, XS_$_, file);\n";
 412 }
 413 print "}\n";
 414
 415 sub output_init {
 416     local($type, $num, $init) = @_;
 417     local($arg) = "ST($num)";
 418
 419     eval qq/print " $init\\\n"/;
 420 }
 421
 422 sub blurt { warn @_; $errors++ }
 423
 424 sub generate_init {
 425     local($type, $num, $var) = @_;
 426     local($arg) = "ST($num)";
 427     local($argoff) = $num - 1;
 428     local($ntype);
 429     local($tk);
 430
 431     blurt("$type not in typemap"), return unless defined($type_kind{$type});
 432     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 433     $subtype = $ntype;
 434     $subtype =~ s/Ptr$//;
 435     $subtype =~ s/Array$//;
 436     $tk = $type_kind{$type};
 437     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 438     $type =~ s/:/_/g;
 439     $expr = $input_expr{$tk};
 440     if ($expr =~ /DO_ARRAY_ELEM/) {
 441         $subexpr = $input_expr{$type_kind{$subtype}};
 442         $subexpr =~ s/ntype/subtype/g;
 443         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 444         $subexpr =~ s/\n\t/\n\t\t/g;
 445         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 446         $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
 447         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 448     }
 449     if (defined($defaults{$var})) {
 450             $expr =~ s/(\t+)/$1    /g;
 451             $expr =~ s/        /\t/g;
 452             eval qq/print "\\t$var;\\n"/;
 453             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 454     } elsif ($expr !~ /^\t\$var =/) {
 455             eval qq/print "\\t$var;\\n"/;
 456             $deferred .= eval qq/"\\n$expr;\\n"/;
 457     } else {
 458             eval qq/print "$expr;\\n"/;
 459     }
 460 }
 461
 462 sub generate_output {
 463     local($type, $num, $var) = @_;
 464     local($arg) = "ST($num)";
 465     local($argoff) = $num - 1;
 466     local($ntype);
 467
 468     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 469             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 470     } else {
 471             blurt("$type not in typemap"), return
 472                 unless defined($type_kind{$type});
 473             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 474             $ntype =~ s/\(\)//g;
 475             $subtype = $ntype;
 476             $subtype =~ s/Ptr$//;
 477             $subtype =~ s/Array$//;
 478             $expr = $output_expr{$type_kind{$type}};
 479             if ($expr =~ /DO_ARRAY_ELEM/) {
 480                 $subexpr = $output_expr{$type_kind{$subtype}};
 481                 $subexpr =~ s/ntype/subtype/g;
 482                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 483                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 484                 $subexpr =~ s/\n\t/\n\t\t/g;
 485                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 486                 eval "print qq\f$expr\f";
 487             }
 488             elsif ($arg eq 'ST(0)') {
 489                 if ($expr =~ /^\t\$arg = /) {
 490                     eval "print qq\f$expr\f";
 491                     print "\tsv_2mortal(ST(0));\n";
 492                 }
 493                 else {
 494                     print "\tST(0) = sv_newmortal();\n";
 495                     eval "print qq\f$expr\f";
 496                 }
 497             }
 498     }
 499 }
 500
 501 sub map_type {
 502     local($type) = @_;
 503
 504     $type =~ s/:/_/g;
 505     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 506             return "$1 *";
 507     } else {
 508             return $type;
 509     }
 510 }
 511
 512 exit $errors;