Commit | Line | Data |
2304df62 |
1 | #!./miniperl |
75f92628 |
2 | |
3 | =head1 NAME |
4 | |
5 | xsubpp - compiler to convert Perl XS code into C code |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>] file.xs |
10 | |
11 | =head1 DESCRIPTION |
12 | |
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. |
17 | |
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. |
21 | |
22 | ../../../typemap:../../typemap:../typemap:typemap |
23 | |
24 | =head1 OPTIONS |
25 | |
26 | =over 5 |
27 | |
28 | =item B<-C++> |
29 | |
30 | Adds ``extern "C"'' to the C code. |
31 | |
32 | |
33 | =item B<-except> |
34 | |
35 | Adds exception handling stubs to the C code. |
36 | |
37 | =item B<-typemap typemap> |
38 | |
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. |
42 | |
43 | =back |
44 | |
45 | =head1 ENVIRONMENT |
46 | |
47 | No environment variables are used. |
48 | |
49 | =head1 AUTHOR |
50 | |
51 | Larry Wall |
52 | |
53 | =head1 SEE ALSO |
54 | |
55 | perl(1) |
56 | |
57 | =cut |
93a17b20 |
58 | |
a0d0e21e |
59 | $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n"; |
93a17b20 |
60 | |
8990e307 |
61 | SWITCH: while ($ARGV[0] =~ s/^-//) { |
93a17b20 |
62 | $flag = shift @ARGV; |
8990e307 |
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'; |
93a17b20 |
67 | die $usage; |
68 | } |
8990e307 |
69 | @ARGV == 1 or die $usage; |
70 | chop($pwd = `pwd`); |
748a9306 |
71 | # Check for error message from VMS |
72 | if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} } |
8990e307 |
73 | ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)# |
a0d0e21e |
74 | or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 |
75 | or ($dir, $filename) = ('.', $ARGV[0]); |
76 | chdir($dir); |
93a17b20 |
77 | |
78 | $typemap = shift @ARGV; |
8990e307 |
79 | foreach $typemap (@tm) { |
80 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
93a17b20 |
81 | } |
748a9306 |
82 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
83 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
84 | ../typemap typemap); |
8990e307 |
85 | foreach $typemap (@tm) { |
86 | open(TYPEMAP, $typemap) || next; |
87 | $mode = Typemap; |
88 | $current = \$junk; |
89 | while (<TYPEMAP>) { |
90 | next if /^#/; |
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) { |
95 | chop; |
96 | ($typename, $kind) = split(/\t+/, $_, 2); |
97 | $type_kind{$typename} = $kind if $kind ne ''; |
463ee0b2 |
98 | } |
8990e307 |
99 | elsif ($mode eq Input) { |
100 | if (/^\s/) { |
101 | $$current .= $_; |
102 | } |
103 | else { |
104 | s/\s*$//; |
a0d0e21e |
105 | $input_expr{$_} = ''; |
8990e307 |
106 | $current = \$input_expr{$_}; |
107 | } |
93a17b20 |
108 | } |
8990e307 |
109 | else { |
110 | if (/^\s/) { |
111 | $$current .= $_; |
112 | } |
113 | else { |
114 | s/\s*$//; |
a0d0e21e |
115 | $output_expr{$_} = ''; |
8990e307 |
116 | $current = \$output_expr{$_}; |
117 | } |
93a17b20 |
118 | } |
8990e307 |
119 | } |
120 | close(TYPEMAP); |
121 | } |
93a17b20 |
122 | |
8990e307 |
123 | foreach $key (keys %input_expr) { |
124 | $input_expr{$key} =~ s/\n+$//; |
125 | } |
93a17b20 |
126 | |
8990e307 |
127 | sub Q { |
128 | local $text = shift; |
129 | $text =~ tr/#//d; |
2304df62 |
130 | $text =~ s/\[\[/{/g; |
131 | $text =~ s/\]\]/}/g; |
8990e307 |
132 | $text; |
93a17b20 |
133 | } |
134 | |
8990e307 |
135 | open(F, $filename) || die "cannot open $filename\n"; |
136 | |
93a17b20 |
137 | while (<F>) { |
a0d0e21e |
138 | last if ($Module, $foo, $Package, $foo1, $Prefix) = |
139 | /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/; |
140 | print $_; |
93a17b20 |
141 | } |
2304df62 |
142 | exit 0 if $_ eq ""; |
143 | $lastline = $_; |
93a17b20 |
144 | |
2304df62 |
145 | sub fetch_para { |
146 | # parse paragraph |
147 | @line = (); |
148 | if ($lastline ne "") { |
149 | if ($lastline =~ |
a0d0e21e |
150 | /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) { |
2304df62 |
151 | $Module = $1; |
152 | $foo = $2; |
153 | $Package = $3; |
154 | $foo1 = $4; |
155 | $Prefix = $5; |
a0d0e21e |
156 | ($Module_cname = $Module) =~ s/\W/_/g; |
2304df62 |
157 | ($Packid = $Package) =~ s/:/_/g; |
158 | $Packprefix = $Package; |
159 | $Packprefix .= "::" if defined $Packprefix && $Packprefix ne ""; |
160 | while (<F>) { |
161 | chop; |
a0d0e21e |
162 | next if /^#/ && |
163 | !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; |
2304df62 |
164 | last if /^\S/; |
165 | } |
166 | push(@line, $_) if $_ ne ""; |
93a17b20 |
167 | } |
2304df62 |
168 | else { |
169 | push(@line, $lastline); |
93a17b20 |
170 | } |
2304df62 |
171 | $lastline = ""; |
172 | while (<F>) { |
a0d0e21e |
173 | next if /^#/ && |
174 | !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; |
2304df62 |
175 | chop; |
176 | if (/^\S/ && @line && $line[-1] eq "") { |
177 | $lastline = $_; |
178 | last; |
179 | } |
180 | else { |
181 | push(@line, $_); |
182 | } |
93a17b20 |
183 | } |
a0d0e21e |
184 | pop(@line) while @line && $line[-1] =~ /^\s*$/; |
2304df62 |
185 | } |
a0d0e21e |
186 | $PPCODE = grep(/PPCODE:/, @line); |
2304df62 |
187 | scalar @line; |
188 | } |
93a17b20 |
189 | |
2304df62 |
190 | while (&fetch_para) { |
191 | # initialize info arrays |
192 | undef(%args_match); |
193 | undef(%var_types); |
194 | undef(%var_addr); |
195 | undef(%defaults); |
196 | undef($class); |
197 | undef($static); |
198 | undef($elipsis); |
199 | |
200 | # extract return type, function name and arguments |
201 | $ret_type = shift(@line); |
a0d0e21e |
202 | if ($ret_type =~ /^BOOT:/) { |
203 | push (@BootCode, @line, "", "") ; |
204 | next ; |
205 | } |
2304df62 |
206 | if ($ret_type =~ /^static\s+(.*)$/) { |
207 | $static = 1; |
208 | $ret_type = $1; |
209 | } |
210 | $func_header = shift(@line); |
211 | ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/; |
212 | if ($func_name =~ /(.*)::(.*)/) { |
213 | $class = $1; |
214 | $func_name = $2; |
215 | } |
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); |
a0d0e21e |
220 | if (defined($class)) { |
221 | if (defined($static)) { |
222 | unshift(@args, "CLASS"); |
223 | $orig_args = "CLASS, $orig_args"; |
224 | $orig_args =~ s/^CLASS, $/CLASS/; |
225 | } |
226 | else { |
2304df62 |
227 | unshift(@args, "THIS"); |
228 | $orig_args = "THIS, $orig_args"; |
229 | $orig_args =~ s/^THIS, $/THIS/; |
a0d0e21e |
230 | } |
2304df62 |
231 | } |
232 | $orig_args =~ s/"/\\"/g; |
233 | $min_args = $num_args = @args; |
234 | foreach $i (0..$num_args-1) { |
235 | if ($args[$i] =~ s/\.\.\.//) { |
236 | $elipsis = 1; |
237 | $min_args--; |
238 | if ($args[i] eq '' && $i == $num_args - 1) { |
239 | pop(@args); |
240 | last; |
241 | } |
242 | } |
243 | if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) { |
244 | $min_args--; |
245 | $args[$i] = $1; |
246 | $defaults{$args[$i]} = $2; |
247 | $defaults{$args[$i]} =~ s/"/\\"/g; |
248 | } |
249 | } |
a0d0e21e |
250 | if (defined($class)) { |
2304df62 |
251 | $func_args = join(", ", @args[1..$#args]); |
252 | } else { |
253 | $func_args = join(", ", @args); |
254 | } |
255 | @args_match{@args} = 1..@args; |
256 | |
257 | # print function header |
a0d0e21e |
258 | print Q<<"EOF"; |
259 | #XS(XS_${Packid}_$func_name) |
2304df62 |
260 | #[[ |
a0d0e21e |
261 | # dXSARGS; |
93a17b20 |
262 | EOF |
2304df62 |
263 | if ($elipsis) { |
264 | $cond = qq(items < $min_args); |
265 | } |
266 | elsif ($min_args == $num_args) { |
267 | $cond = qq(items != $min_args); |
268 | } |
269 | else { |
270 | $cond = qq(items < $min_args || items > $num_args); |
271 | } |
8990e307 |
272 | |
2304df62 |
273 | print Q<<"EOF" if $except; |
274 | # char errbuf[1024]; |
275 | # *errbuf = '\0'; |
276 | EOF |
277 | |
278 | print Q<<"EOF"; |
8990e307 |
279 | # if ($cond) { |
280 | # croak("Usage: $pname($orig_args)"); |
281 | # } |
93a17b20 |
282 | EOF |
283 | |
a0d0e21e |
284 | print Q<<"EOF" if $PPCODE; |
285 | # SP -= items; |
286 | EOF |
287 | |
2304df62 |
288 | # Now do a block of some sort. |
93a17b20 |
289 | |
2304df62 |
290 | $condnum = 0; |
291 | if (!@line) { |
292 | @line = "CLEANUP:"; |
293 | } |
294 | while (@line) { |
93a17b20 |
295 | if ($_[0] =~ s/^\s*CASE\s*:\s*//) { |
2304df62 |
296 | $cond = shift(@line); |
297 | if ($condnum == 0) { |
298 | print " if ($cond)\n"; |
299 | } |
300 | elsif ($cond ne '') { |
301 | print " else if ($cond)\n"; |
302 | } |
303 | else { |
304 | print " else\n"; |
305 | } |
306 | $condnum++; |
93a17b20 |
307 | } |
308 | |
8990e307 |
309 | if ($except) { |
310 | print Q<<"EOF"; |
2304df62 |
311 | # TRY [[ |
93a17b20 |
312 | EOF |
8990e307 |
313 | } |
314 | else { |
315 | print Q<<"EOF"; |
2304df62 |
316 | # [[ |
93a17b20 |
317 | EOF |
8990e307 |
318 | } |
93a17b20 |
319 | |
320 | # do initialization of input variables |
321 | $thisdone = 0; |
322 | $retvaldone = 0; |
463ee0b2 |
323 | $deferred = ""; |
2304df62 |
324 | while (@line) { |
325 | $_ = shift(@line); |
93a17b20 |
326 | last if /^\s*NOT_IMPLEMENTED_YET/; |
2304df62 |
327 | last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/; |
93a17b20 |
328 | ($var_type, $var_name, $var_init) = |
329 | /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/; |
748a9306 |
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+$/); |
93a17b20 |
339 | if ($var_name =~ /^&/) { |
340 | $var_name =~ s/^&//; |
341 | $var_addr{$var_name} = 1; |
342 | } |
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/; |
350 | } |
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"); |
355 | } elsif ($var_num) { |
356 | # generate initialization code |
357 | &generate_init($var_type, $var_num, $var_name); |
358 | } else { |
359 | print ";\n"; |
360 | } |
361 | } else { |
362 | print "\t$var_name;\n"; |
363 | } |
364 | } |
a0d0e21e |
365 | if (!$thisdone && defined($class)) { |
366 | if (defined($static)) { |
367 | print "\tchar *"; |
368 | $var_types{"CLASS"} = "char *"; |
369 | &generate_init("char *", 1, "CLASS"); |
370 | } |
371 | else { |
93a17b20 |
372 | print "\t$class *"; |
373 | $var_types{"THIS"} = "$class *"; |
374 | &generate_init("$class *", 1, "THIS"); |
a0d0e21e |
375 | } |
93a17b20 |
376 | } |
377 | |
378 | # do code |
379 | if (/^\s*NOT_IMPLEMENTED_YET/) { |
463ee0b2 |
380 | print "\ncroak(\"$pname: not implemented yet\");\n"; |
93a17b20 |
381 | } else { |
382 | if ($ret_type ne "void") { |
383 | print "\t" . &map_type($ret_type) . "\tRETVAL;\n" |
384 | if !$retvaldone; |
385 | $args_match{"RETVAL"} = 0; |
386 | $var_types{"RETVAL"} = $ret_type; |
387 | } |
2304df62 |
388 | if (/^\s*PPCODE:/) { |
2304df62 |
389 | print $deferred; |
390 | while (@line) { |
391 | $_ = shift(@line); |
a0d0e21e |
392 | die "PPCODE must be last thing" |
393 | if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; |
2304df62 |
394 | print "$_\n"; |
395 | } |
a0d0e21e |
396 | print "\tPUTBACK;\n\treturn;\n"; |
2304df62 |
397 | } elsif (/^\s*CODE:/) { |
398 | print $deferred; |
399 | while (@line) { |
400 | $_ = shift(@line); |
93a17b20 |
401 | last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; |
402 | print "$_\n"; |
403 | } |
a0d0e21e |
404 | } elsif ($func_name eq "DESTROY") { |
405 | print $deferred; |
406 | print "\n\t"; |
407 | print "delete THIS;\n" |
93a17b20 |
408 | } else { |
2304df62 |
409 | print $deferred; |
93a17b20 |
410 | print "\n\t"; |
411 | if ($ret_type ne "void") { |
463ee0b2 |
412 | print "RETVAL = "; |
93a17b20 |
413 | } |
414 | if (defined($static)) { |
a0d0e21e |
415 | if ($func_name =~ /^new/) { |
416 | $func_name = "$class"; |
417 | } |
418 | else { |
93a17b20 |
419 | print "$class::"; |
a0d0e21e |
420 | } |
93a17b20 |
421 | } elsif (defined($class)) { |
422 | print "THIS->"; |
423 | } |
424 | if (defined($spat) && $func_name =~ /^($spat)(.*)$/) { |
425 | $func_name = $2; |
426 | } |
427 | print "$func_name($func_args);\n"; |
428 | &generate_output($ret_type, 0, "RETVAL") |
429 | unless $ret_type eq "void"; |
430 | } |
431 | } |
432 | |
433 | # do output variables |
434 | if (/^\s*OUTPUT\s*:/) { |
2304df62 |
435 | while (@line) { |
436 | $_ = shift(@line); |
93a17b20 |
437 | last if /^\s*CLEANUP\s*:/; |
438 | s/^\s+//; |
439 | ($outarg, $outcode) = split(/\t+/); |
440 | if ($outcode) { |
a0d0e21e |
441 | print "\t$outcode\n"; |
93a17b20 |
442 | } else { |
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, |
447 | $outarg); |
448 | } |
449 | } |
450 | } |
451 | # do cleanup |
452 | if (/^\s*CLEANUP\s*:/) { |
2304df62 |
453 | while (@line) { |
454 | $_ = shift(@line); |
93a17b20 |
455 | last if /^\s*CASE\s*:/; |
456 | print "$_\n"; |
457 | } |
458 | } |
459 | # print function trailer |
8990e307 |
460 | if ($except) { |
461 | print Q<<EOF; |
2304df62 |
462 | # ]] |
8990e307 |
463 | # BEGHANDLERS |
464 | # CATCHALL |
465 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
466 | # ENDHANDLERS |
93a17b20 |
467 | EOF |
8990e307 |
468 | } |
469 | else { |
470 | print Q<<EOF; |
2304df62 |
471 | # ]] |
93a17b20 |
472 | EOF |
8990e307 |
473 | } |
93a17b20 |
474 | if (/^\s*CASE\s*:/) { |
8990e307 |
475 | unshift(@line, $_); |
93a17b20 |
476 | } |
2304df62 |
477 | } |
a0d0e21e |
478 | |
2304df62 |
479 | print Q<<EOF if $except; |
480 | # if (errbuf[0]) |
481 | # croak(errbuf); |
482 | EOF |
a0d0e21e |
483 | |
484 | print Q<<EOF unless $PPCODE; |
485 | # XSRETURN(1); |
486 | EOF |
487 | |
2304df62 |
488 | print Q<<EOF; |
2304df62 |
489 | #]] |
8990e307 |
490 | # |
93a17b20 |
491 | EOF |
492 | } |
493 | |
494 | # print initialization routine |
8990e307 |
495 | print qq/extern "C"\n/ if $cplusplus; |
496 | print Q<<"EOF"; |
a0d0e21e |
497 | #XS(boot_$Module_cname) |
2304df62 |
498 | #[[ |
a0d0e21e |
499 | # dXSARGS; |
8990e307 |
500 | # char* file = __FILE__; |
501 | # |
93a17b20 |
502 | EOF |
503 | |
504 | for (@Func_name) { |
2304df62 |
505 | $pname = shift(@Func_pname); |
a0d0e21e |
506 | print " newXS(\"$pname\", XS_$_, file);\n"; |
507 | } |
508 | |
509 | if (@BootCode) |
510 | { |
511 | print "\n /* Initialisation Section */\n\n" ; |
512 | print grep (s/$/\n/, @BootCode) ; |
513 | print " /* End of Initialisation Section */\n\n" ; |
93a17b20 |
514 | } |
a0d0e21e |
515 | |
516 | print " ST(0) = &sv_yes;\n"; |
517 | print " XSRETURN(1);\n"; |
93a17b20 |
518 | print "}\n"; |
519 | |
520 | sub output_init { |
2304df62 |
521 | local($type, $num, $init) = @_; |
a0d0e21e |
522 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 |
523 | |
2304df62 |
524 | eval qq/print " $init\\\n"/; |
93a17b20 |
525 | } |
526 | |
8990e307 |
527 | sub blurt { warn @_; $errors++ } |
528 | |
93a17b20 |
529 | sub generate_init { |
2304df62 |
530 | local($type, $num, $var) = @_; |
a0d0e21e |
531 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 |
532 | local($argoff) = $num - 1; |
533 | local($ntype); |
534 | local($tk); |
93a17b20 |
535 | |
748a9306 |
536 | blurt("'$type' not in typemap"), return unless defined($type_kind{$type}); |
2304df62 |
537 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
538 | $subtype = $ntype; |
539 | $subtype =~ s/Ptr$//; |
540 | $subtype =~ s/Array$//; |
541 | $tk = $type_kind{$type}; |
542 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; |
543 | $type =~ s/:/_/g; |
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; |
a0d0e21e |
551 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 |
552 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
553 | } |
554 | if (defined($defaults{$var})) { |
555 | $expr =~ s/(\t+)/$1 /g; |
556 | $expr =~ s/ /\t/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"/; |
562 | } else { |
563 | eval qq/print "$expr;\\n"/; |
564 | } |
93a17b20 |
565 | } |
566 | |
567 | sub generate_output { |
2304df62 |
568 | local($type, $num, $var) = @_; |
a0d0e21e |
569 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 |
570 | local($argoff) = $num - 1; |
571 | local($ntype); |
93a17b20 |
572 | |
2304df62 |
573 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
574 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; |
575 | } else { |
748a9306 |
576 | blurt("'$type' not in typemap"), return |
2304df62 |
577 | unless defined($type_kind{$type}); |
578 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
579 | $ntype =~ s/\(\)//g; |
580 | $subtype = $ntype; |
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/; |
a0d0e21e |
591 | eval "print qq\a$expr\a"; |
2304df62 |
592 | } |
a0d0e21e |
593 | elsif ($var eq 'RETVAL') { |
2304df62 |
594 | if ($expr =~ /^\t\$arg = /) { |
a0d0e21e |
595 | eval "print qq\a$expr\a"; |
2304df62 |
596 | print "\tsv_2mortal(ST(0));\n"; |
93a17b20 |
597 | } |
2304df62 |
598 | else { |
8990e307 |
599 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e |
600 | eval "print qq\a$expr\a"; |
463ee0b2 |
601 | } |
2304df62 |
602 | } |
a0d0e21e |
603 | elsif ($arg =~ /^ST\(\d+\)$/) { |
604 | eval "print qq\a$expr\a"; |
605 | } |
606 | elsif ($arg =~ /^ST\(\d+\)$/) { |
607 | eval "print qq\a$expr\a"; |
608 | } |
609 | elsif ($arg =~ /^ST\(\d+\)$/) { |
610 | eval "print qq\a$expr\a"; |
611 | } |
2304df62 |
612 | } |
93a17b20 |
613 | } |
614 | |
615 | sub map_type { |
2304df62 |
616 | local($type) = @_; |
93a17b20 |
617 | |
2304df62 |
618 | $type =~ s/:/_/g; |
619 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
620 | return "$1 *"; |
621 | } else { |
622 | return $type; |
623 | } |
93a17b20 |
624 | } |
8990e307 |
625 | |
748a9306 |
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 |
628 | # number. |
629 | exit $Is_VMS ? 44 : $errors; |