This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5a5:pat/inherit.pat
[perl5.git] / ext / xsubpp.bak
1 #!/usr/bin/perl
2 # $Header$ 
3
4 $usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
5 die $usage unless (@ARGV >= 2 && @ARGV <= 6);
6
7 SWITCH: while ($ARGV[0] =~ /^-/) {
8     $flag = shift @ARGV;
9     $aflag = 1, next SWITCH if $flag =~ /^-a$/;
10     $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
11     $cflag = 1, next SWITCH if $flag =~ /^-c$/;
12     $eflag = 1, next SWITCH if $flag =~ /^-e$/;
13     die $usage;
14 }
15
16 $typemap = shift @ARGV;
17 open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
18 while (<TYPEMAP>) {
19         next if /^\s*$/ || /^#/;
20         chop;
21         ($typename, $kind) = split(/\t+/, $_, 2);
22         $type_kind{$typename} = $kind;
23 }
24 close(TYPEMAP);
25
26 %input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
27
28 T_INT
29         $var = (int)SvIVn($arg)
30 T_ENUM
31         $var = ($type)SvIVn($arg)
32 T_U_INT
33         $var = (unsigned int)SvIVn($arg)
34 T_SHORT
35         $var = (short)SvIVn($arg)
36 T_U_SHORT
37         $var = (unsigned short)SvIVn($arg)
38 T_LONG
39         $var = (long)SvIVn($arg)
40 T_U_LONG
41         $var = (unsigned long)SvIVn($arg)
42 T_CHAR
43         $var = (char)*SvPVn($arg,na)
44 T_U_CHAR
45         $var = (unsigned char)SvIVn($arg)
46 T_FLOAT
47         $var = (float)SvNVn($arg)
48 T_DOUBLE
49         $var = SvNVn($arg)
50 T_STRING
51         $var = SvPVn($arg,na)
52 T_PTR
53         $var = ($type)(unsigned long)SvNVn($arg)
54 T_PTRREF
55         if (SvTYPE($arg) == SVt_REF)
56             $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
57         else
58             croak(\"$var is not a reference\")
59 T_PTROBJ
60         if (sv_isa($arg, \"${ntype}\"))
61             $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
62         else
63             croak(\"$var is not of type ${ntype}\")
64 T_PTRDESC
65         if (sv_isa($arg, \"${ntype}\")) {
66             ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNVn((SV*)SvANY($arg));
67             $var = ${type}_desc->ptr;
68         }
69         else
70             croak(\"$var is not of type ${ntype}\")
71 T_REFREF
72         if (SvTYPE($arg) == SVt_REF)
73             $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
74         else
75             croak(\"$var is not a reference\")
76 T_REFOBJ
77         if (sv_isa($arg, \"${ntype}\"))
78             $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
79         else
80             croak(\"$var is not of type ${ntype}\")
81 T_OPAQUE
82         $var NOT IMPLEMENTED
83 T_OPAQUEPTR
84         $var = ($type)SvPVn($arg,na)
85 T_PACKED
86         $var = XS_unpack_$ntype($arg)
87 T_PACKEDARRAY
88         $var = XS_unpack_$ntype($arg)
89 T_CALLBACK
90         $var = make_perl_cb_$type($arg)
91 T_ARRAY
92         $var = $ntype(items -= $argoff);
93         U32 ix_$var = $argoff;
94         while (items--) {
95             DO_ARRAY_ELEM;
96         }
97 T_DATUM
98         $var.dptr = SvPVn($arg, $var.dsize);
99 T_GDATUM
100         UNIMPLEMENTED
101 T_PLACEHOLDER
102 T_END
103
104 $* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
105 T_INT
106         sv_setiv($arg, (I32)$var);
107 T_ENUM
108         sv_setiv($arg, (I32)$var);
109 T_U_INT
110         sv_setiv($arg, (I32)$var);
111 T_SHORT
112         sv_setiv($arg, (I32)$var);
113 T_U_SHORT
114         sv_setiv($arg, (I32)$var);
115 T_LONG
116         sv_setiv($arg, (I32)$var);
117 T_U_LONG
118         sv_setiv($arg, (I32)$var);
119 T_CHAR
120         sv_setpvn($arg, (char *)&$var, 1);
121 T_U_CHAR
122         sv_setiv($arg, (I32)$var);
123 T_FLOAT
124         sv_setnv($arg, (double)$var);
125 T_DOUBLE
126         sv_setnv($arg, $var);
127 T_STRING
128         sv_setpv($arg, $var);
129 T_PTR
130         sv_setnv($arg, (double)(unsigned long)$var);
131 T_PTRREF
132         sv_setptrref($arg, $var);
133 T_PTROBJ
134         sv_setptrobj($arg, $var, \"${ntype}\");
135 T_PTRDESC
136         sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
137 T_REFREF
138         sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
139                     ($var ? (void*)new $ntype($var) : 0));
140 T_REFOBJ
141         NOT IMPLEMENTED
142 T_OPAQUE
143         sv_setpvn($arg, (char *)&$var, sizeof($var));
144 T_OPAQUEPTR
145         sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
146 T_PACKED
147         XS_pack_$ntype($arg, $var);
148 T_PACKEDARRAY
149         XS_pack_$ntype($arg, $var, count_$ntype);
150 T_DATAUNIT      
151         sv_setpvn($arg, $var.chp(), $var.size());
152 T_CALLBACK
153         sv_setpvn($arg, $var.context.value().chp(),
154                 $var.context.value().size());
155 T_ARRAY
156         ST_EXTEND($var.size);
157         for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
158                 ST(ix_$var) = sv_mortalcopy(&sv_undef);
159         DO_ARRAY_ELEM
160         }
161         sp += $var.size - 1;
162 T_DATUM
163         sv_setpvn($arg, $var.dptr, $var.dsize);
164 T_GDATUM
165         sv_usepvn($arg, $var.dptr, $var.dsize);
166 T_END
167
168 $uvfile = shift @ARGV;
169 open(F, $uvfile) || die "cannot open $uvfile\n";
170
171 if ($eflag) {
172         print qq|#include "cfm/basic.h"\n|;
173 }
174
175 while (<F>) {
176         last if ($Module, $foo, $Package, $foo1, $Prefix) =
177                 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
178         print $_;
179 }
180 $Pack = $Package;
181 $Package .= "::" if defined $Package && $Package ne "";
182 $/ = "";
183
184 while (<F>) {
185         # parse paragraph
186         chop;
187         next if /^\s*$/;
188         next if /^(#.*\n?)+$/;
189         if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
190                 $Module = $1;
191                 $foo = $2;
192                 $Package = $3;
193                 $Pack = $Package;
194                 $foo1 = $4;
195                 $Prefix = $5;
196                 $Package .= "::" if defined $Package && $Package ne "";
197                 next;
198         }
199         split(/[\t ]*\n/);
200
201         # initialize info arrays
202         undef(%args_match);
203         undef(%var_types);
204         undef(%var_addr);
205         undef(%defaults);
206         undef($class);
207         undef($static);
208         undef($elipsis);
209
210         # extract return type, function name and arguments
211         $ret_type = shift(@_);
212         if ($ret_type =~ /^static\s+(.*)$/) {
213                 $static = 1;
214                 $ret_type = $1;
215         }
216         $func_header = shift(@_);
217         ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
218         if ($func_name =~ /(.*)::(.*)/) {
219                 $class = $1;
220                 $func_name = $2;
221         }
222         ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
223         push(@Func_name, "${Pack}_$func_name");
224         push(@Func_pname, $pname);
225         @args = split(/\s*,\s*/, $orig_args);
226         if (defined($class) && !defined($static)) {
227                 unshift(@args, "THIS");
228                 $orig_args = "THIS, $orig_args";
229                 $orig_args =~ s/^THIS, $/THIS/;
230         }
231         $orig_args =~ s/"/\\"/g;
232         $min_args = $num_args = @args;
233         foreach $i (0..$num_args-1) {
234                 if ($args[$i] =~ s/\.\.\.//) {
235                         $elipsis = 1;
236                         $min_args--;
237                         if ($args[i] eq '' && $i == $num_args - 1) {
238                             pop(@args);
239                             last;
240                         }
241                 }
242                 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
243                         $min_args--;
244                         $args[$i] = $1;
245                         $defaults{$args[$i]} = $2;
246                         $defaults{$args[$i]} =~ s/"/\\"/g;
247                 }
248         }
249         if (defined($class) && !defined($static)) {
250                 $func_args = join(", ", @args[1..$#args]);
251         } else {
252                 $func_args = join(", ", @args);
253         }
254         @args_match{@args} = 1..@args;
255
256         # print function header
257         print <<"EOF" if $aflag;
258 static int
259 XS_${Pack}_$func_name(int, int sp, int items)
260 EOF
261         print <<"EOF" if !$aflag;
262 static int
263 XS_${Pack}_$func_name(ix, sp, items)
264 register int ix;
265 register int sp;
266 register int items;
267 EOF
268         print <<"EOF" if $elipsis;
269 {
270     if (items < $min_args) {
271         croak("Usage: $pname($orig_args)");
272     }
273 EOF
274         print <<"EOF" if !$elipsis;
275 {
276     if (items < $min_args || items > $num_args) {
277         croak("Usage: $pname($orig_args)");
278     }
279 EOF
280
281 # Now do a block of some sort.
282
283 $condnum = 0;
284 if (!@_) {
285     @_ = "CLEANUP:";
286 }
287 while (@_) {
288         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
289                 $cond = shift(@_);
290                 if ($condnum == 0) {
291                     print "    if ($cond)\n";
292                 }
293                 elsif ($cond ne '') {
294                     print "    else if ($cond)\n";
295                 }
296                 else {
297                     print "    else\n";
298                 }
299                 $condnum++;
300         }
301
302         print           <<"EOF" if $eflag;
303     TRY {
304 EOF
305         print           <<"EOF" if !$eflag;
306     {
307 EOF
308
309         # do initialization of input variables
310         $thisdone = 0;
311         $retvaldone = 0;
312         $deferred = "";
313         while ($_ = shift(@_)) {
314                 last if /^\s*NOT_IMPLEMENTED_YET/;
315                 last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
316                 ($var_type, $var_name, $var_init) =
317                     /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
318                 if ($var_name =~ /^&/) {
319                         $var_name =~ s/^&//;
320                         $var_addr{$var_name} = 1;
321                 }
322                 $thisdone |= $var_name eq "THIS";
323                 $retvaldone |= $var_name eq "RETVAL";
324                 $var_types{$var_name} = $var_type;
325                 print "\t" . &map_type($var_type);
326                 $var_num = $args_match{$var_name};
327                 if ($var_addr{$var_name}) {
328                         $func_args =~ s/\b($var_name)\b/&\1/;
329                 }
330                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
331                         if ($var_init !~ /^\s*$/) {
332                                 &output_init($var_type, $var_num,
333                                     "$var_name $var_init");
334                         } elsif ($var_num) {
335                                 # generate initialization code
336                                 &generate_init($var_type, $var_num, $var_name);
337                         } else {
338                                 print ";\n";
339                         }
340                 } else {
341                         print "\t$var_name;\n";
342                 }
343         }
344         if (!$thisdone && defined($class) && !defined($static)) {
345                 print "\t$class *";
346                 $var_types{"THIS"} = "$class *";
347                 &generate_init("$class *", 1, "THIS");
348         }
349
350         # do code
351         if (/^\s*NOT_IMPLEMENTED_YET/) {
352                 print "\ncroak(\"$pname: not implemented yet\");\n";
353         } else {
354                 if ($ret_type ne "void") {
355                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
356                                 if !$retvaldone;
357                         $args_match{"RETVAL"} = 0;
358                         $var_types{"RETVAL"} = $ret_type;
359                 }
360                 print $deferred;
361                 if (/^\s*CODE:/) {
362                         while ($_ = shift(@_)) {
363                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
364                                 print "$_\n";
365                         }
366                 } else {
367                         print "\n\t";
368                         if ($ret_type ne "void") {
369                                 print "RETVAL = ";
370                         }
371                         if (defined($static)) {
372                                 print "$class::";
373                         } elsif (defined($class)) {
374                                 print "THIS->";
375                         }
376                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
377                                 $func_name = $2;
378                         }
379                         print "$func_name($func_args);\n";
380                         &generate_output($ret_type, 0, "RETVAL")
381                             unless $ret_type eq "void";
382                 }
383         }
384
385         # do output variables
386         if (/^\s*OUTPUT\s*:/) {
387                 while ($_ = shift(@_)) {
388                         last if /^\s*CLEANUP\s*:/;
389                         s/^\s+//;
390                         ($outarg, $outcode) = split(/\t+/);
391                         if ($outcode) {
392                         print "\t$outcode\n";
393                         } else {
394                                 die "$outarg not an argument"
395                                     unless defined($args_match{$outarg});
396                                 $var_num = $args_match{$outarg};
397                                 &generate_output($var_types{$outarg}, $var_num,
398                                     $outarg); 
399                         }
400                 }
401         }
402         # do cleanup
403         if (/^\s*CLEANUP\s*:/) {
404             while ($_ = shift(@_)) {
405                     last if /^\s*CASE\s*:/;
406                     print "$_\n";
407             }
408         }
409         # print function trailer
410         print <<EOF if $eflag;
411     }
412     BEGHANDLERS
413     CATCHALL
414         croak("%s: %s\\tpropagated", Xname, Xreason);
415     ENDHANDLERS
416 EOF
417         print <<EOF if !$eflag;
418     }
419 EOF
420         if (/^\s*CASE\s*:/) {
421             unshift(@_, $_);
422         }
423 }
424         print <<EOF;
425     return sp;
426 }
427
428 EOF
429 }
430
431 # print initialization routine
432 print qq/extern "C"\n/ if $cflag;
433 print <<"EOF";
434 int init_$Module(ix,sp,items)
435 int ix;
436 int sp;
437 int items;
438 {
439     char* file = __FILE__;
440
441 EOF
442
443 for (@Func_name) {
444         $pname = shift(@Func_pname);
445         print "    newXSUB(\"$pname\", 0, XS_$_, file);\n";
446 }
447 print "}\n";
448
449 sub output_init {
450         local($type, $num, $init) = @_;
451         local($arg) = "ST($num)";
452
453         eval qq/print " $init\\\n"/;
454 }
455
456 sub generate_init {
457         local($type, $num, $var) = @_;
458         local($arg) = "ST($num)";
459         local($argoff) = $num - 1;
460         local($ntype);
461
462         die "$type not in typemap" if !defined($type_kind{$type});
463         ($ntype = $type) =~ s/\s*\*/Ptr/g;
464         $subtype = $ntype;
465         $subtype =~ s/Ptr$//;
466         $subtype =~ s/Array$//;
467         $expr = $input_expr{$type_kind{$type}};
468         if ($expr =~ /DO_ARRAY_ELEM/) {
469             $subexpr = $input_expr{$type_kind{$subtype}};
470             $subexpr =~ s/ntype/subtype/g;
471             $subexpr =~ s/\$arg/ST(ix_$var)/g;
472             $subexpr =~ s/\n\t/\n\t\t/g;
473             $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
474             $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
475             $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
476         }
477         if (defined($defaults{$var})) {
478                 $expr =~ s/(\t+)/$1    /g;
479                 $expr =~ s/        /\t/g;
480                 eval qq/print "\\t$var;\\n"/;
481                 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
482         } elsif ($expr !~ /^\t\$var =/) {
483                 eval qq/print "\\t$var;\\n"/;
484                 $deferred .= eval qq/"\\n$expr;\\n"/;
485         } else {
486                 eval qq/print "$expr;\\n"/;
487         }
488 }
489
490 sub generate_output {
491         local($type, $num, $var) = @_;
492         local($arg) = "ST($num)";
493         local($argoff) = $num - 1;
494         local($ntype);
495
496         if ($type =~ /^array\(([^,]*),(.*)\)/) {
497                 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
498         } else {
499                 die "$type not in typemap" if !defined($type_kind{$type});
500                 ($ntype = $type) =~ s/\s*\*/Ptr/g;
501                 $ntype =~ s/\(\)//g;
502                 $subtype = $ntype;
503                 $subtype =~ s/Ptr$//;
504                 $subtype =~ s/Array$//;
505                 $expr = $output_expr{$type_kind{$type}};
506                 if ($expr =~ /DO_ARRAY_ELEM/) {
507                     $subexpr = $output_expr{$type_kind{$subtype}};
508                     $subexpr =~ s/ntype/subtype/g;
509                     $subexpr =~ s/\$arg/ST(ix_$var)/g;
510                     $subexpr =~ s/\$var/${var}[ix_$var]/g;
511                     $subexpr =~ s/\n\t/\n\t\t/g;
512                     $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
513                 }
514                 elsif ($arg eq 'ST(0)') {
515                     print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
516                 }
517                 eval "print qq\f$expr\f";
518         }
519 }
520
521 sub map_type {
522         local($type) = @_;
523
524         if ($type =~ /^array\(([^,]*),(.*)\)/) {
525                 return "$1 *";
526         } else {
527                 return $type;
528         }
529 }