home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / C / Applications / MacPerl 5.0.3 / MacPerl Source ƒ / Perl5 / ext / xsubpp.unix < prev    next >
Encoding:
Text File  |  1994-12-26  |  14.1 KB  |  617 lines  |  [TEXT/MPS ]

  1. #!./miniperl
  2. 'di ';
  3. 'ds 00 \"';
  4. 'ig 00 ';
  5. # $Header$ 
  6.  
  7. $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
  8.  
  9. SWITCH: while ($ARGV[0] =~ s/^-//) {
  10.     $flag = shift @ARGV;
  11.     $spat = shift,    next SWITCH    if $flag eq 's';
  12.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  13.     $except = 1,    next SWITCH    if $flag eq 'except';
  14.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  15.     die $usage;
  16. }
  17. @ARGV == 1 or die $usage;
  18. chop($pwd = `pwd`);
  19. ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
  20.     or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
  21.     or ($dir, $filename) = ('.', $ARGV[0]);
  22. chdir($dir);
  23.  
  24. $typemap = shift @ARGV;
  25. foreach $typemap (@tm) {
  26.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  27. }
  28. unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
  29. foreach $typemap (@tm) {
  30.     open(TYPEMAP, $typemap) || next;
  31.     $mode = Typemap;
  32.     $current = \$junk;
  33.     while (<TYPEMAP>) {
  34.     next if /^#/;
  35.     if (/^INPUT\s*$/) { $mode = Input, next }
  36.     if (/^OUTPUT\s*$/) { $mode = Output, next }
  37.     if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
  38.     if ($mode eq Typemap) {
  39.         chop;
  40.         ($typename, $kind) = split(/\t+/, $_, 2);
  41.         $type_kind{$typename} = $kind if $kind ne '';
  42.     }
  43.     elsif ($mode eq Input) {
  44.         if (/^\s/) {
  45.         $$current .= $_;
  46.         }
  47.         else {
  48.         s/\s*$//;
  49.         $input_expr{$_} = '';
  50.         $current = \$input_expr{$_};
  51.         }
  52.     }
  53.     else {
  54.         if (/^\s/) {
  55.         $$current .= $_;
  56.         }
  57.         else {
  58.         s/\s*$//;
  59.         $output_expr{$_} = '';
  60.         $current = \$output_expr{$_};
  61.         }
  62.     }
  63.     }
  64.     close(TYPEMAP);
  65. }
  66.  
  67. foreach $key (keys %input_expr) {
  68.     $input_expr{$key} =~ s/\n+$//;
  69. }
  70.  
  71. sub Q {
  72.     local $text = shift;
  73.     $text =~ tr/#//d;
  74.     $text =~ s/\[\[/{/g;
  75.     $text =~ s/\]\]/}/g;
  76.     $text;
  77. }
  78.  
  79. open(F, $filename) || die "cannot open $filename\n";
  80.  
  81. while (<F>) {
  82.     last if ($Module, $foo, $Package, $foo1, $Prefix) =
  83.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
  84.     print $_;
  85. }
  86. exit 0 if $_ eq "";
  87. $lastline = $_;
  88.  
  89. sub fetch_para {
  90.     # parse paragraph
  91.     @line = ();
  92.     if ($lastline ne "") {
  93.     if ($lastline =~
  94.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  95.         $Module = $1;
  96.         $foo = $2;
  97.         $Package = $3;
  98.         $foo1 = $4;
  99.         $Prefix = $5;
  100.         ($Module_cname = $Module) =~ s/\W/_/g;
  101.         ($Packid = $Package) =~ s/:/_/g;
  102.         $Packprefix = $Package;
  103.         $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
  104.         while (<F>) {
  105.         chop;
  106.         next if /^#/ &&
  107.             !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  108.         last if /^\S/;
  109.         }
  110.         push(@line, $_) if $_ ne "";
  111.     }
  112.     else {
  113.         push(@line, $lastline);
  114.     }
  115.     $lastline = "";
  116.     while (<F>) {
  117.         next if /^#/ &&
  118.         !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  119.         chop;
  120.         if (/^\S/ && @line && $line[-1] eq "") {
  121.         $lastline = $_;
  122.         last;
  123.         }
  124.         else {
  125.         push(@line, $_);
  126.         }
  127.     }
  128.     pop(@line) while @line && $line[-1] =~ /^\s*$/;
  129.     }
  130.     $PPCODE = grep(/PPCODE:/, @line);
  131.     scalar @line;
  132. }
  133.  
  134. while (&fetch_para) {
  135.     # initialize info arrays
  136.     undef(%args_match);
  137.     undef(%var_types);
  138.     undef(%var_addr);
  139.     undef(%defaults);
  140.     undef($class);
  141.     undef($static);
  142.     undef($elipsis);
  143.  
  144.     # extract return type, function name and arguments
  145.     $ret_type = shift(@line);
  146.     if ($ret_type =~ /^BOOT:/) {
  147.         push (@BootCode, @line, "", "") ;
  148.         next ;
  149.     }
  150.     if ($ret_type =~ /^static\s+(.*)$/) {
  151.         $static = 1;
  152.         $ret_type = $1;
  153.     }
  154.     $func_header = shift(@line);
  155.     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
  156.     if ($func_name =~ /(.*)::(.*)/) {
  157.         $class = $1;
  158.         $func_name = $2;
  159.     }
  160.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  161.     push(@Func_name, "${Packid}_$func_name");
  162.     push(@Func_pname, $pname);
  163.     @args = split(/\s*,\s*/, $orig_args);
  164.     if (defined($class)) {
  165.     if (defined($static)) {
  166.         unshift(@args, "CLASS");
  167.         $orig_args = "CLASS, $orig_args";
  168.         $orig_args =~ s/^CLASS, $/CLASS/;
  169.     }
  170.     else {
  171.         unshift(@args, "THIS");
  172.         $orig_args = "THIS, $orig_args";
  173.         $orig_args =~ s/^THIS, $/THIS/;
  174.     }
  175.     }
  176.     $orig_args =~ s/"/\\"/g;
  177.     $min_args = $num_args = @args;
  178.     foreach $i (0..$num_args-1) {
  179.         if ($args[$i] =~ s/\.\.\.//) {
  180.             $elipsis = 1;
  181.             $min_args--;
  182.             if ($args[i] eq '' && $i == $num_args - 1) {
  183.             pop(@args);
  184.             last;
  185.             }
  186.         }
  187.         if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
  188.             $min_args--;
  189.             $args[$i] = $1;
  190.             $defaults{$args[$i]} = $2;
  191.             $defaults{$args[$i]} =~ s/"/\\"/g;
  192.         }
  193.     }
  194.     if (defined($class)) {
  195.         $func_args = join(", ", @args[1..$#args]);
  196.     } else {
  197.         $func_args = join(", ", @args);
  198.     }
  199.     @args_match{@args} = 1..@args;
  200.  
  201.     # print function header
  202.     print Q<<"EOF";
  203. #XS(XS_${Packid}_$func_name)
  204. #[[
  205. #    dXSARGS;
  206. EOF
  207.     if ($elipsis) {
  208.     $cond = qq(items < $min_args);
  209.     }
  210.     elsif ($min_args == $num_args) {
  211.     $cond = qq(items != $min_args);
  212.     }
  213.     else {
  214.     $cond = qq(items < $min_args || items > $num_args);
  215.     }
  216.  
  217.     print Q<<"EOF" if $except;
  218. #    char errbuf[1024];
  219. #    *errbuf = '\0';
  220. EOF
  221.  
  222.     print Q<<"EOF";
  223. #    if ($cond) {
  224. #    croak("Usage: $pname($orig_args)");
  225. #    }
  226. EOF
  227.  
  228.     print Q<<"EOF" if $PPCODE;
  229. #    SP -= items;
  230. EOF
  231.  
  232.     # Now do a block of some sort.
  233.  
  234.     $condnum = 0;
  235.     if (!@line) {
  236.     @line = "CLEANUP:";
  237.     }
  238.     while (@line) {
  239.     if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
  240.         $cond = shift(@line);
  241.         if ($condnum == 0) {
  242.         print "    if ($cond)\n";
  243.         }
  244.         elsif ($cond ne '') {
  245.         print "    else if ($cond)\n";
  246.         }
  247.         else {
  248.         print "    else\n";
  249.         }
  250.         $condnum++;
  251.     }
  252.  
  253.     if ($except) {
  254.         print Q<<"EOF";
  255. #    TRY [[
  256. EOF
  257.     }
  258.     else {
  259.         print Q<<"EOF";
  260. #    [[
  261. EOF
  262.     }
  263.  
  264.     # do initialization of input variables
  265.     $thisdone = 0;
  266.     $retvaldone = 0;
  267.     $deferred = "";
  268.     while (@line) {
  269.         $_ = shift(@line);
  270.         last if /^\s*NOT_IMPLEMENTED_YET/;
  271.         last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
  272.         # Catch common error. Much more error checking required here.
  273.         blurt("Error: no tab in $pname argument declaration '$_'\n")
  274.             unless (m/\S+\s*\t\s*\S+/);
  275.         ($var_type, $var_name, $var_init) =
  276.             /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
  277.         if ($var_name =~ /^&/) {
  278.             $var_name =~ s/^&//;
  279.             $var_addr{$var_name} = 1;
  280.         }
  281.         $thisdone |= $var_name eq "THIS";
  282.         $retvaldone |= $var_name eq "RETVAL";
  283.         $var_types{$var_name} = $var_type;
  284.         print "\t" . &map_type($var_type);
  285.         $var_num = $args_match{$var_name};
  286.         if ($var_addr{$var_name}) {
  287.             $func_args =~ s/\b($var_name)\b/&\1/;
  288.         }
  289.         if ($var_init !~ /^=\s*NO_INIT\s*$/) {
  290.             if ($var_init !~ /^\s*$/) {
  291.                 &output_init($var_type, $var_num,
  292.                     "$var_name $var_init");
  293.             } elsif ($var_num) {
  294.                 # generate initialization code
  295.                 &generate_init($var_type, $var_num, $var_name);
  296.             } else {
  297.                 print ";\n";
  298.             }
  299.         } else {
  300.             print "\t$var_name;\n";
  301.         }
  302.     }
  303.     if (!$thisdone && defined($class)) {
  304.         if (defined($static)) {
  305.         print "\tchar *";
  306.         $var_types{"CLASS"} = "char *";
  307.         &generate_init("char *", 1, "CLASS");
  308.         }
  309.         else {
  310.         print "\t$class *";
  311.         $var_types{"THIS"} = "$class *";
  312.         &generate_init("$class *", 1, "THIS");
  313.         }
  314.     }
  315.  
  316.     # do code
  317.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  318.         print "\ncroak(\"$pname: not implemented yet\");\n";
  319.     } else {
  320.         if ($ret_type ne "void") {
  321.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  322.                 if !$retvaldone;
  323.             $args_match{"RETVAL"} = 0;
  324.             $var_types{"RETVAL"} = $ret_type;
  325.         }
  326.         if (/^\s*PPCODE:/) {
  327.             print $deferred;
  328.             while (@line) {
  329.                 $_ = shift(@line);
  330.                 die "PPCODE must be last thing"
  331.                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  332.                 print "$_\n";
  333.             }
  334.             print "\tPUTBACK;\n\treturn;\n";
  335.         } elsif (/^\s*CODE:/) {
  336.             print $deferred;
  337.             while (@line) {
  338.                 $_ = shift(@line);
  339.                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  340.                 print "$_\n";
  341.             }
  342.         } elsif ($func_name eq "DESTROY") {
  343.             print $deferred;
  344.             print "\n\t";
  345.             print "delete THIS;\n"
  346.         } else {
  347.             print $deferred;
  348.             print "\n\t";
  349.             if ($ret_type ne "void") {
  350.                 print "RETVAL = ";
  351.             }
  352.             if (defined($static)) {
  353.                 if ($func_name =~ /^new/) {
  354.                 $func_name = "$class";
  355.                 }
  356.                 else {
  357.                 print "$class::";
  358.                 }
  359.             } elsif (defined($class)) {
  360.                 print "THIS->";
  361.             }
  362.             if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
  363.                 $func_name = $2;
  364.             }
  365.             print "$func_name($func_args);\n";
  366.             &generate_output($ret_type, 0, "RETVAL")
  367.                 unless $ret_type eq "void";
  368.         }
  369.     }
  370.  
  371.     # do output variables
  372.     if (/^\s*OUTPUT\s*:/) {
  373.         while (@line) {
  374.             $_ = shift(@line);
  375.             last if /^\s*CLEANUP\s*:/;
  376.             s/^\s+//;
  377.             ($outarg, $outcode) = split(/\t+/);
  378.             if ($outcode) {
  379.                 print "\t$outcode\n";
  380.             } else {
  381.                 die "$outarg not an argument"
  382.                     unless defined($args_match{$outarg});
  383.                 $var_num = $args_match{$outarg};
  384.                 &generate_output($var_types{$outarg}, $var_num,
  385.                     $outarg); 
  386.             }
  387.         }
  388.     }
  389.     # do cleanup
  390.     if (/^\s*CLEANUP\s*:/) {
  391.         while (@line) {
  392.             $_ = shift(@line);
  393.             last if /^\s*CASE\s*:/;
  394.             print "$_\n";
  395.         }
  396.     }
  397.     # print function trailer
  398.     if ($except) {
  399.         print Q<<EOF;
  400. #    ]]
  401. #    BEGHANDLERS
  402. #    CATCHALL
  403. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  404. #    ENDHANDLERS
  405. EOF
  406.     }
  407.     else {
  408.         print Q<<EOF;
  409. #    ]]
  410. EOF
  411.     }
  412.     if (/^\s*CASE\s*:/) {
  413.         unshift(@line, $_);
  414.     }
  415.     }
  416.  
  417.     print Q<<EOF if $except;
  418. #    if (errbuf[0])
  419. #    croak(errbuf);
  420. EOF
  421.  
  422.     print Q<<EOF unless $PPCODE;
  423. #    XSRETURN(1);
  424. EOF
  425.  
  426.     print Q<<EOF;
  427. #]]
  428. #
  429. EOF
  430. }
  431.  
  432. # print initialization routine
  433. print qq/extern "C"\n/ if $cplusplus;
  434. print Q<<"EOF";
  435. #XS(boot_$Module_cname)
  436. #[[
  437. #    dXSARGS;
  438. #    char* file = __FILE__;
  439. #
  440. EOF
  441.  
  442. for (@Func_name) {
  443.     $pname = shift(@Func_pname);
  444.     print "    newXS(\"$pname\", XS_$_, file);\n";
  445. }
  446.  
  447. if (@BootCode)
  448. {
  449.     print "\n    /* Initialisation Section */\n\n" ;
  450.     print grep (s/$/\n/, @BootCode) ;
  451.     print "    /* End of Initialisation Section */\n\n" ;
  452. }
  453.  
  454. print "    ST(0) = &sv_yes;\n";
  455. print "    XSRETURN(1);\n";
  456. print "}\n";
  457.  
  458. sub output_init {
  459.     local($type, $num, $init) = @_;
  460.     local($arg) = "ST(" . ($num - 1) . ")";
  461.  
  462.     eval qq/print " $init\\\n"/;
  463. }
  464.  
  465. sub blurt { warn @_; $errors++ }
  466.  
  467. sub generate_init {
  468.     local($type, $num, $var) = @_;
  469.     local($arg) = "ST(" . ($num - 1) . ")";
  470.     local($argoff) = $num - 1;
  471.     local($ntype);
  472.     local($tk);
  473.  
  474.     blurt("$type not in typemap"), return unless defined($type_kind{$type});
  475.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  476.     $subtype = $ntype;
  477.     $subtype =~ s/Ptr$//;
  478.     $subtype =~ s/Array$//;
  479.     $tk = $type_kind{$type};
  480.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  481.     $type =~ s/:/_/g;
  482.     $expr = $input_expr{$tk};
  483.     if ($expr =~ /DO_ARRAY_ELEM/) {
  484.     $subexpr = $input_expr{$type_kind{$subtype}};
  485.     $subexpr =~ s/ntype/subtype/g;
  486.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  487.     $subexpr =~ s/\n\t/\n\t\t/g;
  488.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  489.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  490.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  491.     }
  492.     if (defined($defaults{$var})) {
  493.         $expr =~ s/(\t+)/$1    /g;
  494.         $expr =~ s/        /\t/g;
  495.         eval qq/print "\\t$var;\\n"/;
  496.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  497.     } elsif ($expr !~ /^\t\$var =/) {
  498.         eval qq/print "\\t$var;\\n"/;
  499.         $deferred .= eval qq/"\\n$expr;\\n"/;
  500.     } else {
  501.         eval qq/print "$expr;\\n"/;
  502.     }
  503. }
  504.  
  505. sub generate_output {
  506.     local($type, $num, $var) = @_;
  507.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  508.     local($argoff) = $num - 1;
  509.     local($ntype);
  510.  
  511.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  512.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  513.     } else {
  514.         blurt("$type not in typemap"), return
  515.         unless defined($type_kind{$type});
  516.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  517.         $ntype =~ s/\(\)//g;
  518.         $subtype = $ntype;
  519.         $subtype =~ s/Ptr$//;
  520.         $subtype =~ s/Array$//;
  521.         $expr = $output_expr{$type_kind{$type}};
  522.         if ($expr =~ /DO_ARRAY_ELEM/) {
  523.         $subexpr = $output_expr{$type_kind{$subtype}};
  524.         $subexpr =~ s/ntype/subtype/g;
  525.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  526.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  527.         $subexpr =~ s/\n\t/\n\t\t/g;
  528.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  529.         eval "print qq\a$expr\a";
  530.         }
  531.         elsif ($var eq 'RETVAL') {
  532.         if ($expr =~ /^\t\$arg = /) {
  533.             eval "print qq\a$expr\a";
  534.             print "\tsv_2mortal(ST(0));\n";
  535.         }
  536.         else {
  537.             print "\tST(0) = sv_newmortal();\n";
  538.             eval "print qq\a$expr\a";
  539.         }
  540.         }
  541.         elsif ($arg =~ /^ST\(\d+\)$/) {
  542.         eval "print qq\a$expr\a";
  543.         }
  544.         elsif ($arg =~ /^ST\(\d+\)$/) {
  545.         eval "print qq\a$expr\a";
  546.         }
  547.         elsif ($arg =~ /^ST\(\d+\)$/) {
  548.         eval "print qq\a$expr\a";
  549.         }
  550.     }
  551. }
  552.  
  553. sub map_type {
  554.     local($type) = @_;
  555.  
  556.     $type =~ s/:/_/g;
  557.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  558.         return "$1 *";
  559.     } else {
  560.         return $type;
  561.     }
  562. }
  563.  
  564. exit $errors;
  565.  
  566. ##############################################################################
  567.  
  568.     # These next few lines are legal in both Perl and nroff.
  569.  
  570. .00 ;            # finish .ig
  571.  
  572. 'di            \" finish diversion--previous line must be blank
  573. .nr nl 0-1        \" fake up transition to first page again
  574. .nr % 0            \" start at page 1
  575. '; __END__ ############# From here on it's a standard manual page ############
  576. .TH XSUBPP 1 "August 9, 1994"
  577. .AT 3
  578. .SH NAME
  579. xsubpp \- compiler to convert Perl XS code into C code
  580. .SH SYNOPSIS
  581. .B xsubpp [-C++] [-except] [-typemap typemap] file.xs
  582. .SH DESCRIPTION
  583. .I xsubpp
  584. will compile XS code into C code by embedding the constructs necessary to
  585. let C functions manipulate Perl values and creates the glue necessary to let
  586. Perl access those functions.  The compiler uses typemaps to determine how
  587. to map C function parameters and variables to Perl values.
  588. .PP
  589. The compiler will search for typemap files called
  590. .I typemap.
  591. It will use the following search path to find default typemaps, with the
  592. rightmost typemap taking precedence.
  593. .br
  594. .nf
  595.     ../../../typemap:../../typemap:../typemap:typemap
  596. .fi
  597. .SH OPTIONS
  598. .TP
  599. .B \-C++
  600. .br
  601. Adds ``extern "C"'' to the C code.
  602. .TP
  603. .B \-except
  604. Adds exception handling stubs to the C code.
  605. .TP
  606. .B \-typemap typemap
  607. Indicates that a user-supplied typemap should take precedence over the
  608. default typemaps.  This option may be used multiple times, with the last
  609. typemap having the highest precedence.
  610. .SH ENVIRONMENT
  611. No environment variables are used.
  612. .SH AUTHOR
  613. Larry Wall
  614. .SH "SEE ALSO"
  615. perl(1)
  616. .ex
  617.