Commit | Line | Data |
---|---|---|
2304df62 | 1 | #!./miniperl |
75f92628 AD |
2 | |
3 | =head1 NAME | |
4 | ||
5 | xsubpp - compiler to convert Perl XS code into C code | |
6 | ||
7 | =head1 SYNOPSIS | |
8 | ||
b26a54d0 | 9 | B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs |
75f92628 AD |
10 | |
11 | =head1 DESCRIPTION | |
12 | ||
b26a54d0 GS |
13 | This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. |
14 | ||
75f92628 AD |
15 | I<xsubpp> will compile XS code into C code by embedding the constructs |
16 | necessary to let C functions manipulate Perl values and creates the glue | |
17 | necessary to let Perl access those functions. The compiler uses typemaps to | |
18 | determine how to map C function parameters and variables to Perl values. | |
19 | ||
20 | The compiler will search for typemap files called I<typemap>. It will use | |
21 | the following search path to find default typemaps, with the rightmost | |
22 | typemap taking precedence. | |
23 | ||
24 | ../../../typemap:../../typemap:../typemap:typemap | |
25 | ||
26 | =head1 OPTIONS | |
27 | ||
b26a54d0 GS |
28 | Note that the C<XSOPT> MakeMaker option may be used to add these options to |
29 | any makefiles generated by MakeMaker. | |
30 | ||
75f92628 AD |
31 | =over 5 |
32 | ||
33 | =item B<-C++> | |
34 | ||
35 | Adds ``extern "C"'' to the C code. | |
36 | ||
75f92628 AD |
37 | =item B<-except> |
38 | ||
39 | Adds exception handling stubs to the C code. | |
40 | ||
41 | =item B<-typemap typemap> | |
42 | ||
43 | Indicates that a user-supplied typemap should take precedence over the | |
44 | default typemaps. This option may be used multiple times, with the last | |
45 | typemap having the highest precedence. | |
46 | ||
8e07c86e AD |
47 | =item B<-v> |
48 | ||
49 | Prints the I<xsubpp> version number to standard output, then exits. | |
50 | ||
8fc38fda | 51 | =item B<-prototypes> |
382b8d97 | 52 | |
8fc38fda | 53 | By default I<xsubpp> will not automatically generate prototype code for |
54 | all xsubs. This flag will enable prototypes. | |
55 | ||
56 | =item B<-noversioncheck> | |
57 | ||
58 | Disables the run time test that determines if the object file (derived | |
59 | from the C<.xs> file) and the C<.pm> files have the same version | |
60 | number. | |
382b8d97 | 61 | |
6f1abe2b JT |
62 | =item B<-nolinenumbers> |
63 | ||
64 | Prevents the inclusion of `#line' directives in the output. | |
65 | ||
b26a54d0 GS |
66 | =item B<-nooptimize> |
67 | ||
68 | Disables certain optimizations. The only optimization that is currently | |
69 | affected is the use of I<target>s by the output C code (see L<perlguts>). | |
70 | This may significantly slow down the generated code, but this is the way | |
71 | B<xsubpp> of 5.005 and earlier operated. | |
72 | ||
c5be433b | 73 | =back |
75f92628 AD |
74 | |
75 | =head1 ENVIRONMENT | |
76 | ||
77 | No environment variables are used. | |
78 | ||
79 | =head1 AUTHOR | |
80 | ||
81 | Larry Wall | |
82 | ||
f06db76b AD |
83 | =head1 MODIFICATION HISTORY |
84 | ||
8e07c86e | 85 | See the file F<changes.pod>. |
e50aee73 | 86 | |
75f92628 AD |
87 | =head1 SEE ALSO |
88 | ||
55a00e51 | 89 | perl(1), perlxs(1), perlxstut(1) |
75f92628 AD |
90 | |
91 | =cut | |
93a17b20 | 92 | |
382b8d97 | 93 | require 5.002; |
774d564b | 94 | use Cwd; |
4230ab3f | 95 | use vars '$cplusplus'; |
7ad6fb0b | 96 | use vars '%v'; |
382b8d97 | 97 | |
01f988be GS |
98 | use Config; |
99 | ||
aa689395 | 100 | sub Q ; |
101 | ||
774d564b | 102 | # Global Constants |
774d564b | 103 | |
cfc02341 | 104 | $XSUBPP_version = "1.9507"; |
aa689395 | 105 | |
106 | my ($Is_VMS, $SymSet); | |
107 | if ($^O eq 'VMS') { | |
108 | $Is_VMS = 1; | |
109 | # Establish set of global symbols with max length 28, since xsubpp | |
110 | # will later add the 'XS_' prefix. | |
111 | require ExtUtils::XSSymSet; | |
112 | $SymSet = new ExtUtils::XSSymSet 28; | |
113 | } | |
8fc38fda | 114 | |
c07a80fd | 115 | $FH = 'File0000' ; |
8fc38fda | 116 | |
b26a54d0 | 117 | $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-s pattern] [-typemap typemap]... file.xs\n"; |
f06db76b | 118 | |
382b8d97 | 119 | $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; |
01f988be GS |
120 | # mjn |
121 | $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; | |
93a17b20 | 122 | |
8e07c86e | 123 | $except = ""; |
8fc38fda | 124 | $WantPrototypes = -1 ; |
125 | $WantVersionChk = 1 ; | |
126 | $ProtoUsed = 0 ; | |
6f1abe2b | 127 | $WantLineNumbers = 1 ; |
b26a54d0 | 128 | $WantOptimize = 1 ; |
8e07c86e | 129 | SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { |
93a17b20 | 130 | $flag = shift @ARGV; |
e50aee73 | 131 | $flag =~ s/^-// ; |
ff68c719 | 132 | $spat = quotemeta shift, next SWITCH if $flag eq 's'; |
8990e307 | 133 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
382b8d97 PM |
134 | $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; |
135 | $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; | |
8fc38fda | 136 | $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; |
137 | $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; | |
c5be433b | 138 | # XXX left this in for compat |
b207eff1 | 139 | $WantCAPI = 1, next SWITCH if $flag eq 'object_capi'; |
8e07c86e | 140 | $except = " TRY", next SWITCH if $flag eq 'except'; |
8990e307 | 141 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
6f1abe2b JT |
142 | $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; |
143 | $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; | |
b26a54d0 GS |
144 | $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; |
145 | $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; | |
146 | (print "xsubpp version $XSUBPP_version\n"), exit | |
8e07c86e | 147 | if $flag eq 'v'; |
93a17b20 LW |
148 | die $usage; |
149 | } | |
8fc38fda | 150 | if ($WantPrototypes == -1) |
151 | { $WantPrototypes = 0} | |
152 | else | |
153 | { $ProtoUsed = 1 } | |
154 | ||
155 | ||
8990e307 | 156 | @ARGV == 1 or die $usage; |
c2960299 | 157 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
57497940 | 158 | or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# |
c2960299 | 159 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 LW |
160 | or ($dir, $filename) = ('.', $ARGV[0]); |
161 | chdir($dir); | |
774d564b | 162 | $pwd = cwd(); |
8fc38fda | 163 | |
164 | ++ $IncludedFiles{$ARGV[0]} ; | |
93a17b20 | 165 | |
4230ab3f | 166 | my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs |
167 | my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); | |
aa689395 | 168 | |
4230ab3f | 169 | |
f06db76b AD |
170 | sub TrimWhitespace |
171 | { | |
172 | $_[0] =~ s/^\s+|\s+$//go ; | |
173 | } | |
174 | ||
175 | sub TidyType | |
176 | { | |
177 | local ($_) = @_ ; | |
178 | ||
179 | # rationalise any '*' by joining them into bunches and removing whitespace | |
180 | s#\s*(\*+)\s*#$1#g; | |
e50aee73 | 181 | s#(\*+)# $1 #g ; |
f06db76b AD |
182 | |
183 | # change multiple whitespace into a single space | |
184 | s/\s+/ /g ; | |
185 | ||
186 | # trim leading & trailing whitespace | |
187 | TrimWhitespace($_) ; | |
188 | ||
189 | $_ ; | |
190 | } | |
191 | ||
93a17b20 | 192 | $typemap = shift @ARGV; |
8990e307 LW |
193 | foreach $typemap (@tm) { |
194 | die "Can't find $typemap in $pwd\n" unless -r $typemap; | |
93a17b20 | 195 | } |
748a9306 LW |
196 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
197 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap | |
198 | ../typemap typemap); | |
8990e307 | 199 | foreach $typemap (@tm) { |
f06db76b AD |
200 | next unless -e $typemap ; |
201 | # skip directories, binary files etc. | |
202 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next | |
203 | unless -T $typemap ; | |
204 | open(TYPEMAP, $typemap) | |
205 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; | |
e50aee73 | 206 | $mode = 'Typemap'; |
c2960299 | 207 | $junk = "" ; |
8990e307 LW |
208 | $current = \$junk; |
209 | while (<TYPEMAP>) { | |
e50aee73 | 210 | next if /^\s*#/; |
e1f0c0aa | 211 | my $line_no = $. + 1; |
8e07c86e AD |
212 | if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
213 | if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } | |
214 | if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } | |
e50aee73 AD |
215 | if ($mode eq 'Typemap') { |
216 | chomp; | |
f06db76b AD |
217 | my $line = $_ ; |
218 | TrimWhitespace($_) ; | |
219 | # skip blank lines and comment lines | |
220 | next if /^$/ or /^#/ ; | |
382b8d97 PM |
221 | my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
222 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; | |
223 | $type = TidyType($type) ; | |
224 | $type_kind{$type} = $kind ; | |
225 | # prototype defaults to '$' | |
93d3b392 | 226 | $proto = "\$" unless $proto ; |
382b8d97 PM |
227 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
228 | unless ValidProtoString($proto) ; | |
229 | $proto_letter{$type} = C_string($proto) ; | |
8e07c86e AD |
230 | } |
231 | elsif (/^\s/) { | |
232 | $$current .= $_; | |
463ee0b2 | 233 | } |
e50aee73 | 234 | elsif ($mode eq 'Input') { |
8e07c86e AD |
235 | s/\s+$//; |
236 | $input_expr{$_} = ''; | |
237 | $current = \$input_expr{$_}; | |
93a17b20 | 238 | } |
8990e307 | 239 | else { |
8e07c86e AD |
240 | s/\s+$//; |
241 | $output_expr{$_} = ''; | |
242 | $current = \$output_expr{$_}; | |
93a17b20 | 243 | } |
8990e307 LW |
244 | } |
245 | close(TYPEMAP); | |
246 | } | |
93a17b20 | 247 | |
8990e307 LW |
248 | foreach $key (keys %input_expr) { |
249 | $input_expr{$key} =~ s/\n+$//; | |
250 | } | |
93a17b20 | 251 | |
b26a54d0 GS |
252 | $bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*]; # ()-balanced |
253 | $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast | |
254 | $size = qr[,\s* (?p{ $bal }) ]x; # Third arg (to setpvn) | |
255 | ||
256 | foreach $key (keys %output_expr) { | |
257 | use re 'eval'; | |
258 | ||
259 | my ($t, $with_size, $arg, $sarg) = | |
260 | ($output_expr{$key} =~ | |
261 | m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn | |
262 | \s* \( \s* $cast \$arg \s* , | |
263 | \s* ( (?p{ $bal }) ) # Set from | |
264 | ( (?p{ $size }) )? # Possible sizeof set-from | |
265 | \) \s* ; \s* $ | |
266 | ]x); | |
267 | $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; | |
268 | } | |
269 | ||
8e07c86e AD |
270 | $END = "!End!\n\n"; # "impossible" keyword (multiple newline) |
271 | ||
272 | # Match an XS keyword | |
382b8d97 PM |
273 | $BLOCK_re= '\s*(' . join('|', qw( |
274 | REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT | |
8fc38fda | 275 | CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE |
cfc02341 | 276 | SCOPE INTERFACE INTERFACE_MACRO C_ARGS |
382b8d97 | 277 | )) . "|$END)\\s*:"; |
8e07c86e AD |
278 | |
279 | # Input: ($_, @line) == unparsed input. | |
280 | # Output: ($_, @line) == (rest of line, following lines). | |
281 | # Return: the matched keyword if found, otherwise 0 | |
282 | sub check_keyword { | |
283 | $_ = shift(@line) while !/\S/ && @line; | |
284 | s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; | |
285 | } | |
286 | ||
287 | ||
6f1abe2b JT |
288 | if ($WantLineNumbers) { |
289 | { | |
290 | package xsubpp::counter; | |
291 | sub TIEHANDLE { | |
292 | my ($class, $cfile) = @_; | |
293 | my $buf = ""; | |
294 | $SECTION_END_MARKER = "#line --- \"$cfile\""; | |
295 | $line_no = 1; | |
296 | bless \$buf; | |
297 | } | |
298 | ||
299 | sub PRINT { | |
300 | my $self = shift; | |
301 | for (@_) { | |
302 | $$self .= $_; | |
303 | while ($$self =~ s/^([^\n]*\n)//) { | |
304 | my $line = $1; | |
305 | ++ $line_no; | |
306 | $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; | |
307 | print STDOUT $line; | |
308 | } | |
309 | } | |
310 | } | |
311 | ||
312 | sub PRINTF { | |
313 | my $self = shift; | |
314 | my $fmt = shift; | |
315 | $self->PRINT(sprintf($fmt, @_)); | |
316 | } | |
317 | ||
318 | sub DESTROY { | |
319 | # Not necessary if we're careful to end with a "\n" | |
320 | my $self = shift; | |
321 | print STDOUT $$self; | |
322 | } | |
323 | } | |
324 | ||
325 | my $cfile = $filename; | |
326 | $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; | |
327 | tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); | |
328 | select PSEUDO_STDOUT; | |
329 | } | |
330 | ||
8e07c86e | 331 | sub print_section { |
6f1abe2b JT |
332 | # the "do" is required for right semantics |
333 | do { $_ = shift(@line) } while !/\S/ && @line; | |
334 | ||
335 | print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") | |
d3308daf | 336 | if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
8e07c86e AD |
337 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
338 | print "$_\n"; | |
339 | } | |
6f1abe2b | 340 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
8e07c86e AD |
341 | } |
342 | ||
cfc02341 IZ |
343 | sub merge_section { |
344 | my $in = ''; | |
345 | ||
346 | while (!/\S/ && @line) { | |
347 | $_ = shift(@line); | |
348 | } | |
349 | ||
350 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { | |
351 | $in .= "$_\n"; | |
352 | } | |
353 | chomp $in; | |
354 | return $in; | |
355 | } | |
356 | ||
8fc38fda | 357 | sub process_keyword($) |
358 | { | |
359 | my($pattern) = @_ ; | |
360 | my $kwd ; | |
361 | ||
362 | &{"${kwd}_handler"}() | |
363 | while $kwd = check_keyword($pattern) ; | |
364 | } | |
365 | ||
8e07c86e AD |
366 | sub CASE_handler { |
367 | blurt ("Error: `CASE:' after unconditional `CASE:'") | |
368 | if $condnum && $cond eq ''; | |
369 | $cond = $_; | |
370 | TrimWhitespace($cond); | |
371 | print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); | |
372 | $_ = '' ; | |
373 | } | |
374 | ||
375 | sub INPUT_handler { | |
376 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
377 | last if /^\s*NOT_IMPLEMENTED_YET/; | |
378 | next unless /\S/; # skip blank lines | |
379 | ||
380 | TrimWhitespace($_) ; | |
381 | my $line = $_ ; | |
382 | ||
383 | # remove trailing semicolon if no initialisation | |
7ad6fb0b | 384 | s/\s*;$//g unless /[=;+].*\S/ ; |
8e07c86e AD |
385 | |
386 | # check for optional initialisation code | |
387 | my $var_init = '' ; | |
7ad6fb0b | 388 | $var_init = $1 if s/\s*([=;+].*)$//s ; |
8e07c86e AD |
389 | $var_init =~ s/"/\\"/g; |
390 | ||
391 | s/\s+/ /g; | |
392 | my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s | |
393 | or blurt("Error: invalid argument declaration '$line'"), next; | |
394 | ||
395 | # Check for duplicate definitions | |
396 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next | |
397 | if $arg_list{$var_name} ++ ; | |
398 | ||
399 | $thisdone |= $var_name eq "THIS"; | |
400 | $retvaldone |= $var_name eq "RETVAL"; | |
401 | $var_types{$var_name} = $var_type; | |
ddf6bed1 IZ |
402 | # XXXX This check is a safeguard against the unfinished conversion of |
403 | # generate_init(). When generate_init() is fixed, | |
404 | # one can use 2-args map_type() unconditionally. | |
405 | if ($var_type =~ / \( \s* \* \s* \) /x) { | |
406 | # Function pointers are not yet supported with &output_init! | |
407 | print "\t" . &map_type($var_type, $var_name); | |
408 | $name_printed = 1; | |
409 | } else { | |
410 | print "\t" . &map_type($var_type); | |
411 | $name_printed = 0; | |
412 | } | |
8e07c86e | 413 | $var_num = $args_match{$var_name}; |
382b8d97 | 414 | |
8fc38fda | 415 | $proto_arg[$var_num] = ProtoString($var_type) |
416 | if $var_num ; | |
8e07c86e AD |
417 | if ($var_addr) { |
418 | $var_addr{$var_name} = 1; | |
419 | $func_args =~ s/\b($var_name)\b/&$1/; | |
420 | } | |
7ad6fb0b | 421 | if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) { |
ddf6bed1 IZ |
422 | if ($name_printed) { |
423 | print ";\n"; | |
424 | } else { | |
9bea678f | 425 | print "\t$var_name;\n"; |
ddf6bed1 | 426 | } |
8e07c86e | 427 | } elsif ($var_init =~ /\S/) { |
ddf6bed1 | 428 | &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); |
8e07c86e AD |
429 | } elsif ($var_num) { |
430 | # generate initialization code | |
ddf6bed1 | 431 | &generate_init($var_type, $var_num, $var_name, $name_printed); |
8e07c86e AD |
432 | } else { |
433 | print ";\n"; | |
434 | } | |
435 | } | |
436 | } | |
437 | ||
438 | sub OUTPUT_handler { | |
439 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
440 | next unless /\S/; | |
ef50df4b GS |
441 | if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { |
442 | $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); | |
443 | next; | |
444 | } | |
8e07c86e AD |
445 | my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; |
446 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next | |
447 | if $outargs{$outarg} ++ ; | |
448 | if (!$gotRETVAL and $outarg eq 'RETVAL') { | |
449 | # deal with RETVAL last | |
450 | $RETVAL_code = $outcode ; | |
451 | $gotRETVAL = 1 ; | |
452 | next ; | |
453 | } | |
454 | blurt ("Error: OUTPUT $outarg not an argument"), next | |
455 | unless defined($args_match{$outarg}); | |
456 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next | |
457 | unless defined $var_types{$outarg} ; | |
f78230ad | 458 | $var_num = $args_match{$outarg}; |
8e07c86e AD |
459 | if ($outcode) { |
460 | print "\t$outcode\n"; | |
f78230ad | 461 | print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; |
8e07c86e | 462 | } else { |
ef50df4b | 463 | &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); |
8e07c86e AD |
464 | } |
465 | } | |
466 | } | |
467 | ||
cfc02341 IZ |
468 | sub C_ARGS_handler() { |
469 | my $in = merge_section(); | |
470 | ||
471 | TrimWhitespace($in); | |
472 | $func_args = $in; | |
473 | } | |
474 | ||
475 | sub INTERFACE_MACRO_handler() { | |
476 | my $in = merge_section(); | |
477 | ||
478 | TrimWhitespace($in); | |
479 | if ($in =~ /\s/) { # two | |
480 | ($interface_macro, $interface_macro_set) = split ' ', $in; | |
481 | } else { | |
482 | $interface_macro = $in; | |
483 | $interface_macro_set = 'UNKNOWN_CVT'; # catch later | |
484 | } | |
485 | $interface = 1; # local | |
486 | $Interfaces = 1; # global | |
487 | } | |
488 | ||
489 | sub INTERFACE_handler() { | |
490 | my $in = merge_section(); | |
491 | ||
492 | TrimWhitespace($in); | |
493 | ||
494 | foreach (split /[\s,]+/, $in) { | |
495 | $Interfaces{$_} = $_; | |
496 | } | |
497 | print Q<<"EOF"; | |
498 | # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); | |
499 | EOF | |
500 | $interface = 1; # local | |
501 | $Interfaces = 1; # global | |
502 | } | |
503 | ||
8fc38fda | 504 | sub CLEANUP_handler() { print_section() } |
505 | sub PREINIT_handler() { print_section() } | |
506 | sub INIT_handler() { print_section() } | |
507 | ||
8e07c86e AD |
508 | sub GetAliases |
509 | { | |
510 | my ($line) = @_ ; | |
511 | my ($orig) = $line ; | |
512 | my ($alias) ; | |
513 | my ($value) ; | |
514 | ||
515 | # Parse alias definitions | |
516 | # format is | |
517 | # alias = value alias = value ... | |
518 | ||
519 | while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { | |
520 | $alias = $1 ; | |
521 | $orig_alias = $alias ; | |
522 | $value = $2 ; | |
523 | ||
524 | # check for optional package definition in the alias | |
525 | $alias = $Packprefix . $alias if $alias !~ /::/ ; | |
526 | ||
527 | # check for duplicate alias name & duplicate value | |
528 | Warn("Warning: Ignoring duplicate alias '$orig_alias'") | |
4230ab3f | 529 | if defined $XsubAliases{$alias} ; |
8e07c86e | 530 | |
4230ab3f | 531 | Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") |
532 | if $XsubAliasValues{$value} ; | |
8e07c86e | 533 | |
4230ab3f | 534 | $XsubAliases = 1; |
535 | $XsubAliases{$alias} = $value ; | |
536 | $XsubAliasValues{$value} = $orig_alias ; | |
8e07c86e AD |
537 | } |
538 | ||
539 | blurt("Error: Cannot parse ALIAS definitions from '$orig'") | |
540 | if $line ; | |
541 | } | |
542 | ||
382b8d97 | 543 | sub ALIAS_handler () |
8e07c86e AD |
544 | { |
545 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
546 | next unless /\S/; | |
547 | TrimWhitespace($_) ; | |
548 | GetAliases($_) if $_ ; | |
549 | } | |
550 | } | |
551 | ||
382b8d97 | 552 | sub REQUIRE_handler () |
8e07c86e AD |
553 | { |
554 | # the rest of the current line should contain a version number | |
555 | my ($Ver) = $_ ; | |
556 | ||
557 | TrimWhitespace($Ver) ; | |
558 | ||
559 | death ("Error: REQUIRE expects a version number") | |
560 | unless $Ver ; | |
561 | ||
562 | # check that the version number is of the form n.n | |
563 | death ("Error: REQUIRE: expected a number, got '$Ver'") | |
564 | unless $Ver =~ /^\d+(\.\d*)?/ ; | |
565 | ||
566 | death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") | |
567 | unless $XSUBPP_version >= $Ver ; | |
568 | } | |
569 | ||
8fc38fda | 570 | sub VERSIONCHECK_handler () |
571 | { | |
572 | # the rest of the current line should contain either ENABLE or | |
573 | # DISABLE | |
574 | ||
575 | TrimWhitespace($_) ; | |
576 | ||
577 | # check for ENABLE/DISABLE | |
578 | death ("Error: VERSIONCHECK: ENABLE/DISABLE") | |
579 | unless /^(ENABLE|DISABLE)/i ; | |
580 | ||
581 | $WantVersionChk = 1 if $1 eq 'ENABLE' ; | |
582 | $WantVersionChk = 0 if $1 eq 'DISABLE' ; | |
583 | ||
584 | } | |
585 | ||
382b8d97 PM |
586 | sub PROTOTYPE_handler () |
587 | { | |
7d41bd0a PM |
588 | my $specified ; |
589 | ||
c07a80fd | 590 | death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
591 | if $proto_in_this_xsub ++ ; | |
592 | ||
382b8d97 PM |
593 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
594 | next unless /\S/; | |
7d41bd0a | 595 | $specified = 1 ; |
382b8d97 PM |
596 | TrimWhitespace($_) ; |
597 | if ($_ eq 'DISABLE') { | |
598 | $ProtoThisXSUB = 0 | |
599 | } | |
600 | elsif ($_ eq 'ENABLE') { | |
601 | $ProtoThisXSUB = 1 | |
602 | } | |
603 | else { | |
604 | # remove any whitespace | |
605 | s/\s+//g ; | |
606 | death("Error: Invalid prototype '$_'") | |
607 | unless ValidProtoString($_) ; | |
608 | $ProtoThisXSUB = C_string($_) ; | |
609 | } | |
610 | } | |
c07a80fd | 611 | |
7d41bd0a PM |
612 | # If no prototype specified, then assume empty prototype "" |
613 | $ProtoThisXSUB = 2 unless $specified ; | |
614 | ||
8fc38fda | 615 | $ProtoUsed = 1 ; |
c07a80fd | 616 | |
382b8d97 PM |
617 | } |
618 | ||
db3b9414 | 619 | sub SCOPE_handler () |
620 | { | |
621 | death("Error: Only 1 SCOPE declaration allowed per xsub") | |
622 | if $scope_in_this_xsub ++ ; | |
623 | ||
624 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
625 | next unless /\S/; | |
626 | TrimWhitespace($_) ; | |
627 | if ($_ =~ /^DISABLE/i) { | |
628 | $ScopeThisXSUB = 0 | |
629 | } | |
630 | elsif ($_ =~ /^ENABLE/i) { | |
631 | $ScopeThisXSUB = 1 | |
632 | } | |
633 | } | |
634 | ||
635 | } | |
636 | ||
382b8d97 PM |
637 | sub PROTOTYPES_handler () |
638 | { | |
639 | # the rest of the current line should contain either ENABLE or | |
640 | # DISABLE | |
641 | ||
642 | TrimWhitespace($_) ; | |
643 | ||
644 | # check for ENABLE/DISABLE | |
645 | death ("Error: PROTOTYPES: ENABLE/DISABLE") | |
646 | unless /^(ENABLE|DISABLE)/i ; | |
647 | ||
648 | $WantPrototypes = 1 if $1 eq 'ENABLE' ; | |
649 | $WantPrototypes = 0 if $1 eq 'DISABLE' ; | |
8fc38fda | 650 | $ProtoUsed = 1 ; |
382b8d97 PM |
651 | |
652 | } | |
653 | ||
8fc38fda | 654 | sub INCLUDE_handler () |
655 | { | |
656 | # the rest of the current line should contain a valid filename | |
657 | ||
658 | TrimWhitespace($_) ; | |
659 | ||
8fc38fda | 660 | death("INCLUDE: filename missing") |
661 | unless $_ ; | |
662 | ||
663 | death("INCLUDE: output pipe is illegal") | |
664 | if /^\s*\|/ ; | |
665 | ||
666 | # simple minded recursion detector | |
667 | death("INCLUDE loop detected") | |
668 | if $IncludedFiles{$_} ; | |
669 | ||
670 | ++ $IncludedFiles{$_} unless /\|\s*$/ ; | |
671 | ||
672 | # Save the current file context. | |
4230ab3f | 673 | push(@XSStack, { |
674 | type => 'file', | |
8fc38fda | 675 | LastLine => $lastline, |
676 | LastLineNo => $lastline_no, | |
677 | Line => \@line, | |
678 | LineNo => \@line_no, | |
679 | Filename => $filename, | |
c07a80fd | 680 | Handle => $FH, |
8fc38fda | 681 | }) ; |
682 | ||
c07a80fd | 683 | ++ $FH ; |
8fc38fda | 684 | |
685 | # open the new file | |
c07a80fd | 686 | open ($FH, "$_") or death("Cannot open '$_': $!") ; |
8fc38fda | 687 | |
688 | print Q<<"EOF" ; | |
689 | # | |
690 | #/* INCLUDE: Including '$_' from '$filename' */ | |
691 | # | |
692 | EOF | |
693 | ||
8fc38fda | 694 | $filename = $_ ; |
695 | ||
c07a80fd | 696 | # Prime the pump by reading the first |
697 | # non-blank line | |
698 | ||
699 | # skip leading blank lines | |
700 | while (<$FH>) { | |
701 | last unless /^\s*$/ ; | |
702 | } | |
703 | ||
704 | $lastline = $_ ; | |
8fc38fda | 705 | $lastline_no = $. ; |
706 | ||
707 | } | |
708 | ||
709 | sub PopFile() | |
710 | { | |
4230ab3f | 711 | return 0 unless $XSStack[-1]{type} eq 'file' ; |
712 | ||
713 | my $data = pop @XSStack ; | |
8fc38fda | 714 | my $ThisFile = $filename ; |
715 | my $isPipe = ($filename =~ /\|\s*$/) ; | |
716 | ||
717 | -- $IncludedFiles{$filename} | |
718 | unless $isPipe ; | |
719 | ||
c07a80fd | 720 | close $FH ; |
8fc38fda | 721 | |
c07a80fd | 722 | $FH = $data->{Handle} ; |
8fc38fda | 723 | $filename = $data->{Filename} ; |
724 | $lastline = $data->{LastLine} ; | |
725 | $lastline_no = $data->{LastLineNo} ; | |
726 | @line = @{ $data->{Line} } ; | |
727 | @line_no = @{ $data->{LineNo} } ; | |
4230ab3f | 728 | |
8fc38fda | 729 | if ($isPipe and $? ) { |
730 | -- $lastline_no ; | |
731 | print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; | |
732 | exit 1 ; | |
733 | } | |
734 | ||
735 | print Q<<"EOF" ; | |
736 | # | |
737 | #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ | |
738 | # | |
739 | EOF | |
740 | ||
741 | return 1 ; | |
742 | } | |
743 | ||
382b8d97 PM |
744 | sub ValidProtoString ($) |
745 | { | |
746 | my($string) = @_ ; | |
747 | ||
748 | if ( $string =~ /^$proto_re+$/ ) { | |
749 | return $string ; | |
750 | } | |
751 | ||
752 | return 0 ; | |
753 | } | |
754 | ||
755 | sub C_string ($) | |
756 | { | |
757 | my($string) = @_ ; | |
758 | ||
759 | $string =~ s[\\][\\\\]g ; | |
760 | $string ; | |
761 | } | |
762 | ||
763 | sub ProtoString ($) | |
764 | { | |
765 | my ($type) = @_ ; | |
766 | ||
93d3b392 | 767 | $proto_letter{$type} or "\$" ; |
382b8d97 PM |
768 | } |
769 | ||
8e07c86e AD |
770 | sub check_cpp { |
771 | my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); | |
772 | if (@cpp) { | |
773 | my ($cpp, $cpplevel); | |
774 | for $cpp (@cpp) { | |
775 | if ($cpp =~ /^\#\s*if/) { | |
776 | $cpplevel++; | |
777 | } elsif (!$cpplevel) { | |
778 | Warn("Warning: #else/elif/endif without #if in this function"); | |
4230ab3f | 779 | print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" |
780 | if $XSStack[-1]{type} eq 'if'; | |
8e07c86e AD |
781 | return; |
782 | } elsif ($cpp =~ /^\#\s*endif/) { | |
783 | $cpplevel--; | |
784 | } | |
785 | } | |
786 | Warn("Warning: #if without #endif in this function") if $cpplevel; | |
787 | } | |
788 | } | |
789 | ||
790 | ||
8990e307 | 791 | sub Q { |
e50aee73 | 792 | my($text) = @_; |
4633a7c4 | 793 | $text =~ s/^#//gm; |
2304df62 AD |
794 | $text =~ s/\[\[/{/g; |
795 | $text =~ s/\]\]/}/g; | |
8990e307 | 796 | $text; |
93a17b20 LW |
797 | } |
798 | ||
c07a80fd | 799 | open($FH, $filename) or die "cannot open $filename: $!\n"; |
c2960299 | 800 | |
f06db76b | 801 | # Identify the version of xsubpp used |
f06db76b | 802 | print <<EOM ; |
e50aee73 AD |
803 | /* |
804 | * This file was generated automatically by xsubpp version $XSUBPP_version from the | |
93d3b392 | 805 | * contents of $filename. Do not edit this file, edit $filename instead. |
e50aee73 AD |
806 | * |
807 | * ANY CHANGES MADE HERE WILL BE LOST! | |
f06db76b AD |
808 | * |
809 | */ | |
e50aee73 | 810 | |
f06db76b | 811 | EOM |
6f1abe2b JT |
812 | |
813 | ||
814 | print("#line 1 \"$filename\"\n") | |
815 | if $WantLineNumbers; | |
f06db76b | 816 | |
c07a80fd | 817 | while (<$FH>) { |
e50aee73 AD |
818 | last if ($Module, $Package, $Prefix) = |
819 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; | |
01f988be GS |
820 | |
821 | if ($OBJ) { | |
b85ee828 | 822 | s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; |
01f988be | 823 | } |
a0d0e21e | 824 | print $_; |
93a17b20 | 825 | } |
e50aee73 AD |
826 | &Exit unless defined $_; |
827 | ||
cfc02341 IZ |
828 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
829 | ||
8fc38fda | 830 | $lastline = $_; |
831 | $lastline_no = $.; | |
93a17b20 | 832 | |
c07a80fd | 833 | # Read next xsub into @line from ($lastline, <$FH>). |
2304df62 AD |
834 | sub fetch_para { |
835 | # parse paragraph | |
4230ab3f | 836 | death ("Error: Unterminated `#if/#ifdef/#ifndef'") |
837 | if !defined $lastline && $XSStack[-1]{type} eq 'if'; | |
2304df62 | 838 | @line = (); |
c2960299 | 839 | @line_no = () ; |
4230ab3f | 840 | return PopFile() if !defined $lastline; |
e50aee73 AD |
841 | |
842 | if ($lastline =~ | |
843 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { | |
844 | $Module = $1; | |
8e07c86e AD |
845 | $Package = defined($2) ? $2 : ''; # keep -w happy |
846 | $Prefix = defined($3) ? $3 : ''; # keep -w happy | |
ff68c719 | 847 | $Prefix = quotemeta $Prefix ; |
e50aee73 | 848 | ($Module_cname = $Module) =~ s/\W/_/g; |
8e07c86e | 849 | ($Packid = $Package) =~ tr/:/_/; |
e50aee73 | 850 | $Packprefix = $Package; |
8e07c86e | 851 | $Packprefix .= "::" if $Packprefix ne ""; |
2304df62 | 852 | $lastline = ""; |
e50aee73 AD |
853 | } |
854 | ||
855 | for(;;) { | |
856 | if ($lastline !~ /^\s*#/ || | |
4230ab3f | 857 | # CPP directives: |
858 | # ANSI: if ifdef ifndef elif else endif define undef | |
859 | # line error pragma | |
860 | # gcc: warning include_next | |
861 | # obj-c: import | |
862 | # others: ident (gcc notes that some cpps have this one) | |
863 | $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { | |
e50aee73 AD |
864 | last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; |
865 | push(@line, $lastline); | |
866 | push(@line_no, $lastline_no) ; | |
93a17b20 | 867 | } |
e50aee73 AD |
868 | |
869 | # Read next line and continuation lines | |
c07a80fd | 870 | last unless defined($lastline = <$FH>); |
e50aee73 AD |
871 | $lastline_no = $.; |
872 | my $tmp_line; | |
873 | $lastline .= $tmp_line | |
c07a80fd | 874 | while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); |
e50aee73 | 875 | |
8e07c86e | 876 | chomp $lastline; |
e50aee73 | 877 | $lastline =~ s/^\s+$//; |
2304df62 | 878 | } |
e50aee73 | 879 | pop(@line), pop(@line_no) while @line && $line[-1] eq ""; |
e50aee73 | 880 | 1; |
2304df62 | 881 | } |
93a17b20 | 882 | |
c2960299 | 883 | PARAGRAPH: |
8e07c86e | 884 | while (fetch_para()) { |
e50aee73 | 885 | # Print initial preprocessor statements and blank lines |
4230ab3f | 886 | while (@line && $line[0] !~ /^[^\#]/) { |
887 | my $line = shift(@line); | |
888 | print $line, "\n"; | |
889 | next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; | |
890 | my $statement = $+; | |
891 | if ($statement eq 'if') { | |
892 | $XSS_work_idx = @XSStack; | |
893 | push(@XSStack, {type => 'if'}); | |
894 | } else { | |
895 | death ("Error: `$statement' with no matching `if'") | |
896 | if $XSStack[-1]{type} ne 'if'; | |
897 | if ($XSStack[-1]{varname}) { | |
898 | push(@InitFileCode, "#endif\n"); | |
899 | push(@BootCode, "#endif"); | |
900 | } | |
901 | ||
902 | my(@fns) = keys %{$XSStack[-1]{functions}}; | |
903 | if ($statement ne 'endif') { | |
904 | # Hide the functions defined in other #if branches, and reset. | |
905 | @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; | |
906 | @{$XSStack[-1]}{qw(varname functions)} = ('', {}); | |
907 | } else { | |
908 | my($tmp) = pop(@XSStack); | |
909 | 0 while (--$XSS_work_idx | |
910 | && $XSStack[$XSS_work_idx]{type} ne 'if'); | |
911 | # Keep all new defined functions | |
912 | push(@fns, keys %{$tmp->{other_functions}}); | |
913 | @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; | |
914 | } | |
915 | } | |
916 | } | |
e50aee73 AD |
917 | |
918 | next PARAGRAPH unless @line; | |
919 | ||
4230ab3f | 920 | if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { |
921 | # We are inside an #if, but have not yet #defined its xsubpp variable. | |
922 | print "#define $cpp_next_tmp 1\n\n"; | |
923 | push(@InitFileCode, "#if $cpp_next_tmp\n"); | |
924 | push(@BootCode, "#if $cpp_next_tmp"); | |
925 | $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; | |
926 | } | |
927 | ||
55497cff | 928 | death ("Code is not inside a function" |
929 | ." (maybe last function was ended by a blank line " | |
930 | ." followed by a a statement on column one?)") | |
e50aee73 AD |
931 | if $line[0] =~ /^\s/; |
932 | ||
2304df62 AD |
933 | # initialize info arrays |
934 | undef(%args_match); | |
935 | undef(%var_types); | |
936 | undef(%var_addr); | |
937 | undef(%defaults); | |
938 | undef($class); | |
939 | undef($static); | |
940 | undef($elipsis); | |
f06db76b AD |
941 | undef($wantRETVAL) ; |
942 | undef(%arg_list) ; | |
382b8d97 | 943 | undef(@proto_arg) ; |
c07a80fd | 944 | undef($proto_in_this_xsub) ; |
db3b9414 | 945 | undef($scope_in_this_xsub) ; |
cfc02341 IZ |
946 | undef($interface); |
947 | $interface_macro = 'XSINTERFACE_FUNC' ; | |
948 | $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; | |
382b8d97 | 949 | $ProtoThisXSUB = $WantPrototypes ; |
db3b9414 | 950 | $ScopeThisXSUB = 0; |
2304df62 | 951 | |
8e07c86e | 952 | $_ = shift(@line); |
8fc38fda | 953 | while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { |
954 | &{"${kwd}_handler"}() ; | |
8e07c86e AD |
955 | next PARAGRAPH unless @line ; |
956 | $_ = shift(@line); | |
957 | } | |
c2960299 | 958 | |
8e07c86e AD |
959 | if (check_keyword("BOOT")) { |
960 | &check_cpp; | |
6f1abe2b JT |
961 | push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") |
962 | if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; | |
963 | push (@BootCode, @line, "") ; | |
c2960299 | 964 | next PARAGRAPH ; |
a0d0e21e | 965 | } |
c2960299 | 966 | |
8e07c86e AD |
967 | |
968 | # extract return type, function name and arguments | |
cfc02341 | 969 | ($ret_type) = TidyType($_); |
8e07c86e | 970 | |
c2960299 AD |
971 | # a function definition needs at least 2 lines |
972 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH | |
973 | unless @line ; | |
974 | ||
8e07c86e AD |
975 | $static = 1 if $ret_type =~ s/^static\s+//; |
976 | ||
2304df62 | 977 | $func_header = shift(@line); |
c2960299 | 978 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
f480b56a | 979 | unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s; |
c2960299 | 980 | |
8e07c86e | 981 | ($class, $func_name, $orig_args) = ($1, $2, $3) ; |
f480b56a | 982 | $class = "$4 $class" if $4; |
2304df62 | 983 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
ff68c719 | 984 | ($clean_func_name = $func_name) =~ s/^$Prefix//; |
985 | $Full_func_name = "${Packid}_$clean_func_name"; | |
ff0cee69 | 986 | if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } |
c2960299 AD |
987 | |
988 | # Check for duplicate function definition | |
4230ab3f | 989 | for $tmp (@XSStack) { |
990 | next unless defined $tmp->{functions}{$Full_func_name}; | |
ff68c719 | 991 | Warn("Warning: duplicate function definition '$clean_func_name' detected"); |
4230ab3f | 992 | last; |
8e07c86e | 993 | } |
4230ab3f | 994 | $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; |
cfc02341 | 995 | %XsubAliases = %XsubAliasValues = %Interfaces = (); |
ef50df4b | 996 | $DoSetMagic = 1; |
c2960299 | 997 | |
b7e88d44 GS |
998 | my $temp_args = $orig_args; |
999 | $temp_args =~ s/\\\s*//g; | |
1000 | @args = split(/\s*,\s*/, $temp_args); | |
a0d0e21e | 1001 | if (defined($class)) { |
683d4eee JL |
1002 | my $arg0 = ((defined($static) or $func_name eq 'new') |
1003 | ? "CLASS" : "THIS"); | |
8e07c86e AD |
1004 | unshift(@args, $arg0); |
1005 | ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/; | |
2304df62 AD |
1006 | } |
1007 | $orig_args =~ s/"/\\"/g; | |
1008 | $min_args = $num_args = @args; | |
1009 | foreach $i (0..$num_args-1) { | |
1010 | if ($args[$i] =~ s/\.\.\.//) { | |
1011 | $elipsis = 1; | |
1012 | $min_args--; | |
c2960299 | 1013 | if ($args[$i] eq '' && $i == $num_args - 1) { |
2304df62 AD |
1014 | pop(@args); |
1015 | last; | |
1016 | } | |
1017 | } | |
8e07c86e | 1018 | if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
2304df62 AD |
1019 | $min_args--; |
1020 | $args[$i] = $1; | |
1021 | $defaults{$args[$i]} = $2; | |
1022 | $defaults{$args[$i]} =~ s/"/\\"/g; | |
1023 | } | |
93d3b392 | 1024 | $proto_arg[$i+1] = "\$" ; |
2304df62 | 1025 | } |
a0d0e21e | 1026 | if (defined($class)) { |
2304df62 AD |
1027 | $func_args = join(", ", @args[1..$#args]); |
1028 | } else { | |
1029 | $func_args = join(", ", @args); | |
1030 | } | |
1031 | @args_match{@args} = 1..@args; | |
1032 | ||
8e07c86e | 1033 | $PPCODE = grep(/^\s*PPCODE\s*:/, @line); |
93d3b392 | 1034 | $CODE = grep(/^\s*CODE\s*:/, @line); |
6c5fb52b TB |
1035 | # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) |
1036 | # to set explicit return values. | |
1037 | $EXPLICIT_RETURN = ($CODE && | |
1038 | ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); | |
8e07c86e | 1039 | $ALIAS = grep(/^\s*ALIAS\s*:/, @line); |
cfc02341 | 1040 | $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); |
8e07c86e | 1041 | |
2304df62 | 1042 | # print function header |
a0d0e21e | 1043 | print Q<<"EOF"; |
ff68c719 | 1044 | #XS(XS_${Full_func_name}) |
2304df62 | 1045 | #[[ |
a0d0e21e | 1046 | # dXSARGS; |
93a17b20 | 1047 | EOF |
8e07c86e AD |
1048 | print Q<<"EOF" if $ALIAS ; |
1049 | # dXSI32; | |
1050 | EOF | |
cfc02341 IZ |
1051 | print Q<<"EOF" if $INTERFACE ; |
1052 | # dXSFUNCTION($ret_type); | |
1053 | EOF | |
2304df62 | 1054 | if ($elipsis) { |
8e07c86e | 1055 | $cond = ($min_args ? qq(items < $min_args) : 0); |
2304df62 AD |
1056 | } |
1057 | elsif ($min_args == $num_args) { | |
1058 | $cond = qq(items != $min_args); | |
1059 | } | |
1060 | else { | |
1061 | $cond = qq(items < $min_args || items > $num_args); | |
1062 | } | |
8990e307 | 1063 | |
2304df62 AD |
1064 | print Q<<"EOF" if $except; |
1065 | # char errbuf[1024]; | |
1066 | # *errbuf = '\0'; | |
1067 | EOF | |
1068 | ||
8e07c86e AD |
1069 | if ($ALIAS) |
1070 | { print Q<<"EOF" if $cond } | |
1071 | # if ($cond) | |
cea2e8a9 | 1072 | # Perl_croak(aTHX_ "Usage: %s($orig_args)", GvNAME(CvGV(cv))); |
8e07c86e AD |
1073 | EOF |
1074 | else | |
1075 | { print Q<<"EOF" if $cond } | |
1076 | # if ($cond) | |
cea2e8a9 | 1077 | # Perl_croak(aTHX_ "Usage: $pname($orig_args)"); |
93a17b20 LW |
1078 | EOF |
1079 | ||
a0d0e21e LW |
1080 | print Q<<"EOF" if $PPCODE; |
1081 | # SP -= items; | |
1082 | EOF | |
1083 | ||
2304df62 | 1084 | # Now do a block of some sort. |
93a17b20 | 1085 | |
2304df62 | 1086 | $condnum = 0; |
8e07c86e AD |
1087 | $cond = ''; # last CASE: condidional |
1088 | push(@line, "$END:"); | |
1089 | push(@line_no, $line_no[-1]); | |
1090 | $_ = ''; | |
1091 | &check_cpp; | |
2304df62 | 1092 | while (@line) { |
8e07c86e AD |
1093 | &CASE_handler if check_keyword("CASE"); |
1094 | print Q<<"EOF"; | |
1095 | # $except [[ | |
93a17b20 LW |
1096 | EOF |
1097 | ||
1098 | # do initialization of input variables | |
1099 | $thisdone = 0; | |
1100 | $retvaldone = 0; | |
463ee0b2 | 1101 | $deferred = ""; |
c2960299 AD |
1102 | %arg_list = () ; |
1103 | $gotRETVAL = 0; | |
f06db76b | 1104 | |
8fc38fda | 1105 | INPUT_handler() ; |
cfc02341 | 1106 | process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ; |
8fc38fda | 1107 | |
db3b9414 | 1108 | print Q<<"EOF" if $ScopeThisXSUB; |
1109 | # ENTER; | |
1110 | # [[ | |
1111 | EOF | |
1112 | ||
a0d0e21e | 1113 | if (!$thisdone && defined($class)) { |
683d4eee | 1114 | if (defined($static) or $func_name eq 'new') { |
a0d0e21e LW |
1115 | print "\tchar *"; |
1116 | $var_types{"CLASS"} = "char *"; | |
1117 | &generate_init("char *", 1, "CLASS"); | |
1118 | } | |
1119 | else { | |
93a17b20 LW |
1120 | print "\t$class *"; |
1121 | $var_types{"THIS"} = "$class *"; | |
1122 | &generate_init("$class *", 1, "THIS"); | |
a0d0e21e | 1123 | } |
93a17b20 LW |
1124 | } |
1125 | ||
1126 | # do code | |
1127 | if (/^\s*NOT_IMPLEMENTED_YET/) { | |
cea2e8a9 | 1128 | print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; |
4633a7c4 | 1129 | $_ = '' ; |
93a17b20 LW |
1130 | } else { |
1131 | if ($ret_type ne "void") { | |
ddf6bed1 | 1132 | print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" |
93a17b20 LW |
1133 | if !$retvaldone; |
1134 | $args_match{"RETVAL"} = 0; | |
1135 | $var_types{"RETVAL"} = $ret_type; | |
b26a54d0 GS |
1136 | print "\tdXSTARG;\n" |
1137 | if $WantOptimize and $targetable{$type_kind{$ret_type}}; | |
93a17b20 | 1138 | } |
db3b9414 | 1139 | |
8e07c86e | 1140 | print $deferred; |
db3b9414 | 1141 | |
cfc02341 | 1142 | process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; |
8e07c86e AD |
1143 | |
1144 | if (check_keyword("PPCODE")) { | |
8fc38fda | 1145 | print_section(); |
8e07c86e | 1146 | death ("PPCODE must be last thing") if @line; |
db3b9414 | 1147 | print "\tLEAVE;\n" if $ScopeThisXSUB; |
a0d0e21e | 1148 | print "\tPUTBACK;\n\treturn;\n"; |
8e07c86e | 1149 | } elsif (check_keyword("CODE")) { |
8fc38fda | 1150 | print_section() ; |
1151 | } elsif (defined($class) and $func_name eq "DESTROY") { | |
a0d0e21e | 1152 | print "\n\t"; |
8e07c86e | 1153 | print "delete THIS;\n"; |
93a17b20 LW |
1154 | } else { |
1155 | print "\n\t"; | |
1156 | if ($ret_type ne "void") { | |
463ee0b2 | 1157 | print "RETVAL = "; |
e50aee73 | 1158 | $wantRETVAL = 1; |
93a17b20 LW |
1159 | } |
1160 | if (defined($static)) { | |
683d4eee | 1161 | if ($func_name eq 'new') { |
8fc38fda | 1162 | $func_name = "$class"; |
8e07c86e AD |
1163 | } else { |
1164 | print "${class}::"; | |
a0d0e21e | 1165 | } |
93a17b20 | 1166 | } elsif (defined($class)) { |
683d4eee | 1167 | if ($func_name eq 'new') { |
8fc38fda | 1168 | $func_name .= " $class"; |
1169 | } else { | |
93a17b20 | 1170 | print "THIS->"; |
8fc38fda | 1171 | } |
93a17b20 | 1172 | } |
e50aee73 AD |
1173 | $func_name =~ s/^($spat)// |
1174 | if defined($spat); | |
cfc02341 | 1175 | $func_name = 'XSFUNCTION' if $interface; |
93a17b20 | 1176 | print "$func_name($func_args);\n"; |
93a17b20 LW |
1177 | } |
1178 | } | |
1179 | ||
1180 | # do output variables | |
8e07c86e AD |
1181 | $gotRETVAL = 0; |
1182 | undef $RETVAL_code ; | |
1183 | undef %outargs ; | |
8fc38fda | 1184 | process_keyword("OUTPUT|ALIAS|PROTOTYPE"); |
f06db76b AD |
1185 | |
1186 | # all OUTPUT done, so now push the return value on the stack | |
8e07c86e AD |
1187 | if ($gotRETVAL && $RETVAL_code) { |
1188 | print "\t$RETVAL_code\n"; | |
1189 | } elsif ($gotRETVAL || $wantRETVAL) { | |
b26a54d0 GS |
1190 | my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; |
1191 | my $var = 'RETVAL'; | |
1192 | my $type = $ret_type; | |
1193 | ||
1194 | # 0: type, 1: with_size, 2: how, 3: how_size | |
1195 | if ($t and not $t->[1] and $t->[0] eq 'p') { | |
1196 | # PUSHp corresponds to setpvn. Treate setpv directly | |
1197 | my $what = eval qq("$t->[2]"); | |
1198 | warn $@ if $@; | |
1199 | ||
1200 | print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; | |
1201 | } | |
1202 | elsif ($t) { | |
1203 | my $what = eval qq("$t->[2]"); | |
1204 | warn $@ if $@; | |
1205 | ||
1206 | my $size = $t->[3]; | |
1207 | $size = '' unless defined $size; | |
1208 | $size = eval qq("$size"); | |
1209 | warn $@ if $@; | |
1210 | print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; | |
1211 | } | |
1212 | else { | |
1213 | # RETVAL almost never needs SvSETMAGIC() | |
1214 | &generate_output($ret_type, 0, 'RETVAL', 0); | |
1215 | } | |
8e07c86e | 1216 | } |
f06db76b | 1217 | |
93a17b20 | 1218 | # do cleanup |
8fc38fda | 1219 | process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; |
8e07c86e | 1220 | |
db3b9414 | 1221 | print Q<<"EOF" if $ScopeThisXSUB; |
1222 | # ]] | |
1223 | EOF | |
1224 | print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; | |
1225 | # LEAVE; | |
1226 | EOF | |
1227 | ||
93a17b20 | 1228 | # print function trailer |
8e07c86e | 1229 | print Q<<EOF; |
2304df62 | 1230 | # ]] |
8e07c86e AD |
1231 | EOF |
1232 | print Q<<EOF if $except; | |
8990e307 LW |
1233 | # BEGHANDLERS |
1234 | # CATCHALL | |
1235 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); | |
1236 | # ENDHANDLERS | |
93a17b20 | 1237 | EOF |
8e07c86e AD |
1238 | if (check_keyword("CASE")) { |
1239 | blurt ("Error: No `CASE:' at top of function") | |
1240 | unless $condnum; | |
1241 | $_ = "CASE: $_"; # Restore CASE: label | |
1242 | next; | |
8990e307 | 1243 | } |
8e07c86e AD |
1244 | last if $_ eq "$END:"; |
1245 | death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); | |
2304df62 | 1246 | } |
a0d0e21e | 1247 | |
2304df62 AD |
1248 | print Q<<EOF if $except; |
1249 | # if (errbuf[0]) | |
cea2e8a9 | 1250 | # Perl_croak(aTHX_ errbuf); |
2304df62 | 1251 | EOF |
a0d0e21e | 1252 | |
7c5b83de | 1253 | if ($ret_type ne "void" or $EXPLICIT_RETURN) { |
93d3b392 | 1254 | print Q<<EOF unless $PPCODE; |
a0d0e21e LW |
1255 | # XSRETURN(1); |
1256 | EOF | |
93d3b392 | 1257 | } else { |
1258 | print Q<<EOF unless $PPCODE; | |
1259 | # XSRETURN_EMPTY; | |
1260 | EOF | |
1261 | } | |
a0d0e21e | 1262 | |
2304df62 | 1263 | print Q<<EOF; |
2304df62 | 1264 | #]] |
8990e307 | 1265 | # |
93a17b20 | 1266 | EOF |
382b8d97 | 1267 | |
4230ab3f | 1268 | my $newXS = "newXS" ; |
1269 | my $proto = "" ; | |
1270 | ||
382b8d97 PM |
1271 | # Build the prototype string for the xsub |
1272 | if ($ProtoThisXSUB) { | |
4230ab3f | 1273 | $newXS = "newXSproto"; |
1274 | ||
6f1abe2b | 1275 | if ($ProtoThisXSUB eq 2) { |
4230ab3f | 1276 | # User has specified empty prototype |
1277 | $proto = ', ""' ; | |
1278 | } | |
6f1abe2b | 1279 | elsif ($ProtoThisXSUB ne 1) { |
7d41bd0a | 1280 | # User has specified a prototype |
4230ab3f | 1281 | $proto = ', "' . $ProtoThisXSUB . '"'; |
382b8d97 PM |
1282 | } |
1283 | else { | |
1284 | my $s = ';'; | |
1285 | if ($min_args < $num_args) { | |
1286 | $s = ''; | |
1287 | $proto_arg[$min_args] .= ";" ; | |
1288 | } | |
4230ab3f | 1289 | push @proto_arg, "$s\@" |
382b8d97 PM |
1290 | if $elipsis ; |
1291 | ||
4230ab3f | 1292 | $proto = ', "' . join ("", @proto_arg) . '"'; |
382b8d97 PM |
1293 | } |
1294 | } | |
1295 | ||
4230ab3f | 1296 | if (%XsubAliases) { |
1297 | $XsubAliases{$pname} = 0 | |
1298 | unless defined $XsubAliases{$pname} ; | |
1299 | while ( ($name, $value) = each %XsubAliases) { | |
1300 | push(@InitFileCode, Q<<"EOF"); | |
1301 | # cv = newXS(\"$name\", XS_$Full_func_name, file); | |
1302 | # XSANY.any_i32 = $value ; | |
1303 | EOF | |
1304 | push(@InitFileCode, Q<<"EOF") if $proto; | |
1305 | # sv_setpv((SV*)cv$proto) ; | |
1306 | EOF | |
1307 | } | |
cfc02341 IZ |
1308 | } |
1309 | elsif ($interface) { | |
1310 | while ( ($name, $value) = each %Interfaces) { | |
1311 | $name = "$Package\::$name" unless $name =~ /::/; | |
1312 | push(@InitFileCode, Q<<"EOF"); | |
1313 | # cv = newXS(\"$name\", XS_$Full_func_name, file); | |
1314 | # $interface_macro_set(cv,$value) ; | |
1315 | EOF | |
1316 | push(@InitFileCode, Q<<"EOF") if $proto; | |
1317 | # sv_setpv((SV*)cv$proto) ; | |
1318 | EOF | |
1319 | } | |
4230ab3f | 1320 | } |
1321 | else { | |
1322 | push(@InitFileCode, | |
1323 | " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); | |
1324 | } | |
93a17b20 LW |
1325 | } |
1326 | ||
1327 | # print initialization routine | |
7ee8c957 | 1328 | |
e3b8966e | 1329 | print Q<<"EOF"; |
e3b8966e GS |
1330 | ##ifdef __cplusplus |
1331 | #extern "C" | |
1332 | ##endif | |
7ee8c957 GS |
1333 | EOF |
1334 | ||
8990e307 | 1335 | print Q<<"EOF"; |
a0d0e21e | 1336 | #XS(boot_$Module_cname) |
7ee8c957 GS |
1337 | EOF |
1338 | ||
7ee8c957 | 1339 | print Q<<"EOF"; |
2304df62 | 1340 | #[[ |
a0d0e21e | 1341 | # dXSARGS; |
8990e307 LW |
1342 | # char* file = __FILE__; |
1343 | # | |
93a17b20 LW |
1344 | EOF |
1345 | ||
8fc38fda | 1346 | print Q<<"EOF" if $WantVersionChk ; |
1347 | # XS_VERSION_BOOTCHECK ; | |
1348 | # | |
1349 | EOF | |
1350 | ||
cfc02341 | 1351 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e AD |
1352 | # { |
1353 | # CV * cv ; | |
1354 | # | |
1355 | EOF | |
1356 | ||
4230ab3f | 1357 | print @InitFileCode; |
a0d0e21e | 1358 | |
cfc02341 | 1359 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e AD |
1360 | # } |
1361 | EOF | |
1362 | ||
a0d0e21e LW |
1363 | if (@BootCode) |
1364 | { | |
6f1abe2b JT |
1365 | print "\n /* Initialisation Section */\n\n" ; |
1366 | @line = @BootCode; | |
1367 | print_section(); | |
8e07c86e | 1368 | print "\n /* End of Initialisation Section */\n\n" ; |
93a17b20 | 1369 | } |
a0d0e21e | 1370 | |
e50aee73 | 1371 | print Q<<"EOF";; |
3280af22 | 1372 | # XSRETURN_YES; |
e50aee73 | 1373 | #]] |
e3b8966e GS |
1374 | # |
1375 | EOF | |
1376 | ||
8fc38fda | 1377 | warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") |
1378 | unless $ProtoUsed ; | |
e50aee73 AD |
1379 | &Exit; |
1380 | ||
93a17b20 | 1381 | sub output_init { |
ddf6bed1 | 1382 | local($type, $num, $var, $init, $name_printed) = @_; |
a0d0e21e | 1383 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 | 1384 | |
7ad6fb0b | 1385 | if( $init =~ /^=/ ) { |
ddf6bed1 IZ |
1386 | if ($name_printed) { |
1387 | eval qq/print " $init\\n"/; | |
1388 | } else { | |
1389 | eval qq/print "\\t$var $init\\n"/; | |
1390 | } | |
7ad6fb0b TM |
1391 | warn $@ if $@; |
1392 | } else { | |
1393 | if( $init =~ s/^\+// && $num ) { | |
ddf6bed1 IZ |
1394 | &generate_init($type, $num, $var, $name_printed); |
1395 | } elsif ($name_printed) { | |
1396 | print ";\n"; | |
1397 | $init =~ s/^;//; | |
7ad6fb0b TM |
1398 | } else { |
1399 | eval qq/print "\\t$var;\\n"/; | |
1400 | warn $@ if $@; | |
1401 | $init =~ s/^;//; | |
1402 | } | |
1403 | $deferred .= eval qq/"\\n\\t$init\\n"/; | |
1404 | warn $@ if $@; | |
1405 | } | |
93a17b20 LW |
1406 | } |
1407 | ||
c2960299 AD |
1408 | sub Warn |
1409 | { | |
1410 | # work out the line number | |
1411 | my $line_no = $line_no[@line_no - @line -1] ; | |
1412 | ||
1413 | print STDERR "@_ in $filename, line $line_no\n" ; | |
1414 | } | |
1415 | ||
1416 | sub blurt | |
1417 | { | |
1418 | Warn @_ ; | |
1419 | $errors ++ | |
1420 | } | |
1421 | ||
1422 | sub death | |
1423 | { | |
1424 | Warn @_ ; | |
1425 | exit 1 ; | |
1426 | } | |
8990e307 | 1427 | |
93a17b20 | 1428 | sub generate_init { |
2304df62 | 1429 | local($type, $num, $var) = @_; |
a0d0e21e | 1430 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 AD |
1431 | local($argoff) = $num - 1; |
1432 | local($ntype); | |
1433 | local($tk); | |
93a17b20 | 1434 | |
f06db76b | 1435 | $type = TidyType($type) ; |
c2960299 AD |
1436 | blurt("Error: '$type' not in typemap"), return |
1437 | unless defined($type_kind{$type}); | |
1438 | ||
2304df62 | 1439 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
8e07c86e | 1440 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 AD |
1441 | $tk = $type_kind{$type}; |
1442 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; | |
8e07c86e | 1443 | $type =~ tr/:/_/; |
c2960299 AD |
1444 | blurt("Error: No INPUT definition for type '$type' found"), return |
1445 | unless defined $input_expr{$tk} ; | |
2304df62 AD |
1446 | $expr = $input_expr{$tk}; |
1447 | if ($expr =~ /DO_ARRAY_ELEM/) { | |
c2960299 AD |
1448 | blurt("Error: '$subtype' not in typemap"), return |
1449 | unless defined($type_kind{$subtype}); | |
1450 | blurt("Error: No INPUT definition for type '$subtype' found"), return | |
1451 | unless defined $input_expr{$type_kind{$subtype}} ; | |
2304df62 AD |
1452 | $subexpr = $input_expr{$type_kind{$subtype}}; |
1453 | $subexpr =~ s/ntype/subtype/g; | |
1454 | $subexpr =~ s/\$arg/ST(ix_$var)/g; | |
1455 | $subexpr =~ s/\n\t/\n\t\t/g; | |
93d3b392 | 1456 | $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e | 1457 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 AD |
1458 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1459 | } | |
db3b9414 | 1460 | if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments |
1461 | $ScopeThisXSUB = 1; | |
1462 | } | |
2304df62 AD |
1463 | if (defined($defaults{$var})) { |
1464 | $expr =~ s/(\t+)/$1 /g; | |
1465 | $expr =~ s/ /\t/g; | |
ddf6bed1 IZ |
1466 | if ($name_printed) { |
1467 | print ";\n"; | |
1468 | } else { | |
1469 | eval qq/print "\\t$var;\\n"/; | |
1470 | warn $@ if $@; | |
1471 | } | |
2304df62 | 1472 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; |
7ad6fb0b | 1473 | warn $@ if $@; |
db3b9414 | 1474 | } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { |
ddf6bed1 IZ |
1475 | if ($name_printed) { |
1476 | print ";\n"; | |
1477 | } else { | |
1478 | eval qq/print "\\t$var;\\n"/; | |
1479 | warn $@ if $@; | |
1480 | } | |
2304df62 | 1481 | $deferred .= eval qq/"\\n$expr;\\n"/; |
7ad6fb0b | 1482 | warn $@ if $@; |
2304df62 | 1483 | } else { |
ddf6bed1 IZ |
1484 | die "panic: do not know how to handle this branch for function pointers" |
1485 | if $name_printed; | |
2304df62 | 1486 | eval qq/print "$expr;\\n"/; |
7ad6fb0b | 1487 | warn $@ if $@; |
2304df62 | 1488 | } |
93a17b20 LW |
1489 | } |
1490 | ||
1491 | sub generate_output { | |
ef50df4b | 1492 | local($type, $num, $var, $do_setmagic) = @_; |
a0d0e21e | 1493 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 AD |
1494 | local($argoff) = $num - 1; |
1495 | local($ntype); | |
93a17b20 | 1496 | |
f06db76b | 1497 | $type = TidyType($type) ; |
2304df62 | 1498 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
4bd3d083 | 1499 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; |
ef50df4b | 1500 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2304df62 | 1501 | } else { |
f06db76b | 1502 | blurt("Error: '$type' not in typemap"), return |
2304df62 | 1503 | unless defined($type_kind{$type}); |
c2960299 AD |
1504 | blurt("Error: No OUTPUT definition for type '$type' found"), return |
1505 | unless defined $output_expr{$type_kind{$type}} ; | |
2304df62 AD |
1506 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
1507 | $ntype =~ s/\(\)//g; | |
8e07c86e | 1508 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 AD |
1509 | $expr = $output_expr{$type_kind{$type}}; |
1510 | if ($expr =~ /DO_ARRAY_ELEM/) { | |
c2960299 AD |
1511 | blurt("Error: '$subtype' not in typemap"), return |
1512 | unless defined($type_kind{$subtype}); | |
1513 | blurt("Error: No OUTPUT definition for type '$subtype' found"), return | |
1514 | unless defined $output_expr{$type_kind{$subtype}} ; | |
2304df62 AD |
1515 | $subexpr = $output_expr{$type_kind{$subtype}}; |
1516 | $subexpr =~ s/ntype/subtype/g; | |
1517 | $subexpr =~ s/\$arg/ST(ix_$var)/g; | |
1518 | $subexpr =~ s/\$var/${var}[ix_$var]/g; | |
1519 | $subexpr =~ s/\n\t/\n\t\t/g; | |
1520 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; | |
a0d0e21e | 1521 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1522 | warn $@ if $@; |
ef50df4b | 1523 | print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
2304df62 | 1524 | } |
a0d0e21e | 1525 | elsif ($var eq 'RETVAL') { |
a2baab1c IZ |
1526 | if ($expr =~ /^\t\$arg = new/) { |
1527 | # We expect that $arg has refcnt 1, so we need to | |
1528 | # mortalize it. | |
a0d0e21e | 1529 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1530 | warn $@ if $@; |
2304df62 | 1531 | print "\tsv_2mortal(ST(0));\n"; |
ef50df4b | 1532 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
93a17b20 | 1533 | } |
a2baab1c IZ |
1534 | elsif ($expr =~ /^\s*\$arg\s*=/) { |
1535 | # We expect that $arg has refcnt >=1, so we need | |
d689ffdd | 1536 | # to mortalize it! |
a2baab1c | 1537 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1538 | warn $@ if $@; |
d689ffdd | 1539 | print "\tsv_2mortal(ST(0));\n"; |
ef50df4b | 1540 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
a2baab1c | 1541 | } |
2304df62 | 1542 | else { |
a2baab1c IZ |
1543 | # Just hope that the entry would safely write it |
1544 | # over an already mortalized value. By | |
1545 | # coincidence, something like $arg = &sv_undef | |
1546 | # works too. | |
8990e307 | 1547 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e | 1548 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1549 | warn $@ if $@; |
ef50df4b | 1550 | # new mortals don't have set magic |
463ee0b2 | 1551 | } |
2304df62 | 1552 | } |
a0d0e21e LW |
1553 | elsif ($arg =~ /^ST\(\d+\)$/) { |
1554 | eval "print qq\a$expr\a"; | |
7ad6fb0b | 1555 | warn $@ if $@; |
ef50df4b | 1556 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
a0d0e21e | 1557 | } |
2304df62 | 1558 | } |
93a17b20 LW |
1559 | } |
1560 | ||
1561 | sub map_type { | |
ddf6bed1 | 1562 | my($type, $varname) = @_; |
93a17b20 | 1563 | |
8e07c86e AD |
1564 | $type =~ tr/:/_/; |
1565 | $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; | |
ddf6bed1 IZ |
1566 | if ($varname) { |
1567 | if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { | |
1568 | (substr $type, pos $type, 0) = " $varname "; | |
1569 | } else { | |
1570 | $type .= "\t$varname"; | |
1571 | } | |
1572 | } | |
8e07c86e | 1573 | $type; |
93a17b20 | 1574 | } |
8990e307 | 1575 | |
e50aee73 AD |
1576 | |
1577 | sub Exit { | |
ff0cee69 | 1578 | # If this is VMS, the exit status has meaning to the shell, so we |
1579 | # use a predictable value (SS$_Normal or SS$_Abort) rather than an | |
1580 | # arbitrary number. | |
1581 | # exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; | |
1582 | exit ($errors ? 1 : 0); | |
e50aee73 | 1583 | } |