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 | ||
0ab125c1 NIS |
37 | =item B<-hiertype> |
38 | ||
39 | Retains '::' in type names so that C++ hierachical types can be mapped. | |
40 | ||
75f92628 AD |
41 | =item B<-except> |
42 | ||
43 | Adds exception handling stubs to the C code. | |
44 | ||
45 | =item B<-typemap typemap> | |
46 | ||
47 | Indicates that a user-supplied typemap should take precedence over the | |
48 | default typemaps. This option may be used multiple times, with the last | |
49 | typemap having the highest precedence. | |
50 | ||
8e07c86e AD |
51 | =item B<-v> |
52 | ||
53 | Prints the I<xsubpp> version number to standard output, then exits. | |
54 | ||
8fc38fda | 55 | =item B<-prototypes> |
382b8d97 | 56 | |
8fc38fda | 57 | By default I<xsubpp> will not automatically generate prototype code for |
58 | all xsubs. This flag will enable prototypes. | |
59 | ||
60 | =item B<-noversioncheck> | |
61 | ||
62 | Disables the run time test that determines if the object file (derived | |
63 | from the C<.xs> file) and the C<.pm> files have the same version | |
64 | number. | |
382b8d97 | 65 | |
6f1abe2b JT |
66 | =item B<-nolinenumbers> |
67 | ||
68 | Prevents the inclusion of `#line' directives in the output. | |
69 | ||
b26a54d0 GS |
70 | =item B<-nooptimize> |
71 | ||
72 | Disables certain optimizations. The only optimization that is currently | |
73 | affected is the use of I<target>s by the output C code (see L<perlguts>). | |
74 | This may significantly slow down the generated code, but this is the way | |
75 | B<xsubpp> of 5.005 and earlier operated. | |
76 | ||
11416672 GS |
77 | =item B<-noinout> |
78 | ||
79 | Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. | |
80 | ||
81 | =item B<-noargtypes> | |
82 | ||
83 | Disable recognition of ANSI-like descriptions of function signature. | |
84 | ||
c5be433b | 85 | =back |
75f92628 AD |
86 | |
87 | =head1 ENVIRONMENT | |
88 | ||
89 | No environment variables are used. | |
90 | ||
91 | =head1 AUTHOR | |
92 | ||
93 | Larry Wall | |
94 | ||
f06db76b AD |
95 | =head1 MODIFICATION HISTORY |
96 | ||
8e07c86e | 97 | See the file F<changes.pod>. |
e50aee73 | 98 | |
75f92628 AD |
99 | =head1 SEE ALSO |
100 | ||
55a00e51 | 101 | perl(1), perlxs(1), perlxstut(1) |
75f92628 AD |
102 | |
103 | =cut | |
93a17b20 | 104 | |
9bdfb4d4 | 105 | require 5.002; |
774d564b | 106 | use Cwd; |
0ab125c1 | 107 | use vars qw($cplusplus $hiertype); |
7ad6fb0b | 108 | use vars '%v'; |
382b8d97 | 109 | |
01f988be GS |
110 | use Config; |
111 | ||
aa689395 | 112 | sub Q ; |
113 | ||
774d564b | 114 | # Global Constants |
774d564b | 115 | |
7817ba4d | 116 | $XSUBPP_version = "1.9508"; |
aa689395 | 117 | |
118 | my ($Is_VMS, $SymSet); | |
119 | if ($^O eq 'VMS') { | |
120 | $Is_VMS = 1; | |
121 | # Establish set of global symbols with max length 28, since xsubpp | |
122 | # will later add the 'XS_' prefix. | |
123 | require ExtUtils::XSSymSet; | |
124 | $SymSet = new ExtUtils::XSSymSet 28; | |
125 | } | |
8fc38fda | 126 | |
c07a80fd | 127 | $FH = 'File0000' ; |
8fc38fda | 128 | |
11416672 | 129 | $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; |
f06db76b | 130 | |
c2452817 | 131 | $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; |
93a17b20 | 132 | |
8e07c86e | 133 | $except = ""; |
8fc38fda | 134 | $WantPrototypes = -1 ; |
135 | $WantVersionChk = 1 ; | |
136 | $ProtoUsed = 0 ; | |
6f1abe2b | 137 | $WantLineNumbers = 1 ; |
b26a54d0 | 138 | $WantOptimize = 1 ; |
54162f5c | 139 | $Overload = 0; |
30d6fba6 | 140 | $Fallback = 'PL_sv_undef'; |
11416672 GS |
141 | |
142 | my $process_inout = 1; | |
143 | my $process_argtypes = 1; | |
144 | ||
8e07c86e | 145 | SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { |
93a17b20 | 146 | $flag = shift @ARGV; |
e50aee73 | 147 | $flag =~ s/^-// ; |
ff68c719 | 148 | $spat = quotemeta shift, next SWITCH if $flag eq 's'; |
8990e307 | 149 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
0ab125c1 | 150 | $hiertype = 1, next SWITCH if $flag eq 'hiertype'; |
382b8d97 PM |
151 | $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; |
152 | $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; | |
8fc38fda | 153 | $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; |
154 | $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; | |
c5be433b | 155 | # XXX left this in for compat |
acfe0abc | 156 | next SWITCH if $flag eq 'object_capi'; |
8e07c86e | 157 | $except = " TRY", next SWITCH if $flag eq 'except'; |
8990e307 | 158 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
6f1abe2b JT |
159 | $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; |
160 | $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; | |
b26a54d0 GS |
161 | $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; |
162 | $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; | |
11416672 GS |
163 | $process_inout = 0, next SWITCH if $flag eq 'noinout'; |
164 | $process_inout = 1, next SWITCH if $flag eq 'inout'; | |
165 | $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; | |
166 | $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; | |
b26a54d0 | 167 | (print "xsubpp version $XSUBPP_version\n"), exit |
8e07c86e | 168 | if $flag eq 'v'; |
93a17b20 LW |
169 | die $usage; |
170 | } | |
8fc38fda | 171 | if ($WantPrototypes == -1) |
172 | { $WantPrototypes = 0} | |
173 | else | |
174 | { $ProtoUsed = 1 } | |
175 | ||
176 | ||
8990e307 | 177 | @ARGV == 1 or die $usage; |
c2960299 | 178 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
57497940 | 179 | or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# |
c2960299 | 180 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 LW |
181 | or ($dir, $filename) = ('.', $ARGV[0]); |
182 | chdir($dir); | |
774d564b | 183 | $pwd = cwd(); |
8fc38fda | 184 | |
185 | ++ $IncludedFiles{$ARGV[0]} ; | |
93a17b20 | 186 | |
4230ab3f | 187 | my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs |
188 | my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); | |
aa689395 | 189 | |
4230ab3f | 190 | |
f06db76b AD |
191 | sub TrimWhitespace |
192 | { | |
193 | $_[0] =~ s/^\s+|\s+$//go ; | |
194 | } | |
195 | ||
196 | sub TidyType | |
197 | { | |
198 | local ($_) = @_ ; | |
199 | ||
200 | # rationalise any '*' by joining them into bunches and removing whitespace | |
201 | s#\s*(\*+)\s*#$1#g; | |
e50aee73 | 202 | s#(\*+)# $1 #g ; |
f06db76b AD |
203 | |
204 | # change multiple whitespace into a single space | |
205 | s/\s+/ /g ; | |
0ab125c1 | 206 | |
f06db76b AD |
207 | # trim leading & trailing whitespace |
208 | TrimWhitespace($_) ; | |
209 | ||
210 | $_ ; | |
211 | } | |
212 | ||
93a17b20 | 213 | $typemap = shift @ARGV; |
8990e307 LW |
214 | foreach $typemap (@tm) { |
215 | die "Can't find $typemap in $pwd\n" unless -r $typemap; | |
93a17b20 | 216 | } |
748a9306 LW |
217 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
218 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap | |
219 | ../typemap typemap); | |
8990e307 | 220 | foreach $typemap (@tm) { |
dd713d92 | 221 | next unless -f $typemap ; |
f06db76b | 222 | # skip directories, binary files etc. |
0ab125c1 | 223 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
f06db76b | 224 | unless -T $typemap ; |
0ab125c1 | 225 | open(TYPEMAP, $typemap) |
f06db76b | 226 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
e50aee73 | 227 | $mode = 'Typemap'; |
c2960299 | 228 | $junk = "" ; |
8990e307 LW |
229 | $current = \$junk; |
230 | while (<TYPEMAP>) { | |
e50aee73 | 231 | next if /^\s*#/; |
0ab125c1 | 232 | my $line_no = $. + 1; |
8e07c86e AD |
233 | if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
234 | if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } | |
235 | if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } | |
e50aee73 AD |
236 | if ($mode eq 'Typemap') { |
237 | chomp; | |
f06db76b AD |
238 | my $line = $_ ; |
239 | TrimWhitespace($_) ; | |
240 | # skip blank lines and comment lines | |
241 | next if /^$/ or /^#/ ; | |
382b8d97 PM |
242 | my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
243 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; | |
244 | $type = TidyType($type) ; | |
245 | $type_kind{$type} = $kind ; | |
246 | # prototype defaults to '$' | |
93d3b392 | 247 | $proto = "\$" unless $proto ; |
0ab125c1 | 248 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
382b8d97 PM |
249 | unless ValidProtoString($proto) ; |
250 | $proto_letter{$type} = C_string($proto) ; | |
8e07c86e AD |
251 | } |
252 | elsif (/^\s/) { | |
253 | $$current .= $_; | |
463ee0b2 | 254 | } |
e50aee73 | 255 | elsif ($mode eq 'Input') { |
8e07c86e AD |
256 | s/\s+$//; |
257 | $input_expr{$_} = ''; | |
258 | $current = \$input_expr{$_}; | |
93a17b20 | 259 | } |
8990e307 | 260 | else { |
8e07c86e AD |
261 | s/\s+$//; |
262 | $output_expr{$_} = ''; | |
263 | $current = \$output_expr{$_}; | |
93a17b20 | 264 | } |
8990e307 LW |
265 | } |
266 | close(TYPEMAP); | |
267 | } | |
93a17b20 | 268 | |
8990e307 | 269 | foreach $key (keys %input_expr) { |
50a63b21 | 270 | $input_expr{$key} =~ s/;*\s+\z//; |
8990e307 | 271 | } |
93a17b20 | 272 | |
14455d6c | 273 | $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced |
b26a54d0 | 274 | $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast |
14455d6c | 275 | $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) |
b26a54d0 GS |
276 | |
277 | foreach $key (keys %output_expr) { | |
278 | use re 'eval'; | |
279 | ||
280 | my ($t, $with_size, $arg, $sarg) = | |
281 | ($output_expr{$key} =~ | |
438cc608 | 282 | m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn |
b26a54d0 | 283 | \s* \( \s* $cast \$arg \s* , |
14455d6c GS |
284 | \s* ( (??{ $bal }) ) # Set from |
285 | ( (??{ $size }) )? # Possible sizeof set-from | |
b26a54d0 GS |
286 | \) \s* ; \s* $ |
287 | ]x); | |
288 | $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; | |
289 | } | |
290 | ||
8e07c86e AD |
291 | $END = "!End!\n\n"; # "impossible" keyword (multiple newline) |
292 | ||
293 | # Match an XS keyword | |
382b8d97 | 294 | $BLOCK_re= '\s*(' . join('|', qw( |
0ab125c1 | 295 | REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT |
be3174d2 | 296 | CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE |
30d6fba6 | 297 | SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK |
382b8d97 | 298 | )) . "|$END)\\s*:"; |
8e07c86e AD |
299 | |
300 | # Input: ($_, @line) == unparsed input. | |
301 | # Output: ($_, @line) == (rest of line, following lines). | |
302 | # Return: the matched keyword if found, otherwise 0 | |
303 | sub check_keyword { | |
304 | $_ = shift(@line) while !/\S/ && @line; | |
305 | s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; | |
306 | } | |
307 | ||
efbca139 | 308 | my ($C_group_rex, $C_arg); |
f8b8e0a4 GS |
309 | # Group in C (no support for comments or literals) |
310 | $C_group_rex = qr/ [({\[] | |
14455d6c | 311 | (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* |
f8b8e0a4 GS |
312 | [)}\]] /x ; |
313 | # Chunk in C without comma at toplevel (no comments): | |
314 | $C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) | |
14455d6c | 315 | | (??{ $C_group_rex }) |
f8b8e0a4 GS |
316 | | " (?: (?> [^\\"]+ ) |
317 | | \\. | |
318 | )* " # String literal | |
319 | | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal | |
320 | )* /xs; | |
8e07c86e | 321 | |
6f1abe2b JT |
322 | if ($WantLineNumbers) { |
323 | { | |
324 | package xsubpp::counter; | |
325 | sub TIEHANDLE { | |
326 | my ($class, $cfile) = @_; | |
327 | my $buf = ""; | |
328 | $SECTION_END_MARKER = "#line --- \"$cfile\""; | |
329 | $line_no = 1; | |
330 | bless \$buf; | |
331 | } | |
332 | ||
333 | sub PRINT { | |
334 | my $self = shift; | |
335 | for (@_) { | |
336 | $$self .= $_; | |
337 | while ($$self =~ s/^([^\n]*\n)//) { | |
338 | my $line = $1; | |
339 | ++ $line_no; | |
340 | $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; | |
341 | print STDOUT $line; | |
342 | } | |
343 | } | |
344 | } | |
345 | ||
346 | sub PRINTF { | |
347 | my $self = shift; | |
348 | my $fmt = shift; | |
349 | $self->PRINT(sprintf($fmt, @_)); | |
350 | } | |
351 | ||
352 | sub DESTROY { | |
353 | # Not necessary if we're careful to end with a "\n" | |
354 | my $self = shift; | |
355 | print STDOUT $$self; | |
356 | } | |
357 | } | |
358 | ||
359 | my $cfile = $filename; | |
360 | $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; | |
361 | tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); | |
362 | select PSEUDO_STDOUT; | |
363 | } | |
364 | ||
8e07c86e | 365 | sub print_section { |
6f1abe2b JT |
366 | # the "do" is required for right semantics |
367 | do { $_ = shift(@line) } while !/\S/ && @line; | |
0ab125c1 | 368 | |
6f1abe2b | 369 | print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") |
d3308daf | 370 | if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
8e07c86e AD |
371 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
372 | print "$_\n"; | |
373 | } | |
6f1abe2b | 374 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
8e07c86e AD |
375 | } |
376 | ||
cfc02341 IZ |
377 | sub merge_section { |
378 | my $in = ''; | |
0ab125c1 | 379 | |
cfc02341 IZ |
380 | while (!/\S/ && @line) { |
381 | $_ = shift(@line); | |
382 | } | |
0ab125c1 | 383 | |
cfc02341 IZ |
384 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
385 | $in .= "$_\n"; | |
386 | } | |
387 | chomp $in; | |
388 | return $in; | |
389 | } | |
390 | ||
8fc38fda | 391 | sub process_keyword($) |
392 | { | |
393 | my($pattern) = @_ ; | |
394 | my $kwd ; | |
395 | ||
0ab125c1 | 396 | &{"${kwd}_handler"}() |
8fc38fda | 397 | while $kwd = check_keyword($pattern) ; |
398 | } | |
399 | ||
8e07c86e AD |
400 | sub CASE_handler { |
401 | blurt ("Error: `CASE:' after unconditional `CASE:'") | |
402 | if $condnum && $cond eq ''; | |
403 | $cond = $_; | |
404 | TrimWhitespace($cond); | |
405 | print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); | |
406 | $_ = '' ; | |
407 | } | |
408 | ||
409 | sub INPUT_handler { | |
410 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
411 | last if /^\s*NOT_IMPLEMENTED_YET/; | |
0ab125c1 | 412 | next unless /\S/; # skip blank lines |
8e07c86e AD |
413 | |
414 | TrimWhitespace($_) ; | |
415 | my $line = $_ ; | |
416 | ||
417 | # remove trailing semicolon if no initialisation | |
7ad6fb0b | 418 | s/\s*;$//g unless /[=;+].*\S/ ; |
8e07c86e | 419 | |
08ff138d IZ |
420 | # Process the length(foo) declarations |
421 | if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { | |
422 | print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; | |
423 | $lengthof{$2} = $name; | |
424 | # $islengthof{$name} = $1; | |
425 | $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; | |
426 | } | |
427 | ||
8e07c86e AD |
428 | # check for optional initialisation code |
429 | my $var_init = '' ; | |
7ad6fb0b | 430 | $var_init = $1 if s/\s*([=;+].*)$//s ; |
8e07c86e AD |
431 | $var_init =~ s/"/\\"/g; |
432 | ||
433 | s/\s+/ /g; | |
0f568861 | 434 | my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s |
8e07c86e AD |
435 | or blurt("Error: invalid argument declaration '$line'"), next; |
436 | ||
437 | # Check for duplicate definitions | |
438 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next | |
0ab125c1 | 439 | if $arg_list{$var_name}++ |
08ff138d | 440 | or defined $argtype_seen{$var_name} and not $processing_arg_with_types; |
8e07c86e AD |
441 | |
442 | $thisdone |= $var_name eq "THIS"; | |
443 | $retvaldone |= $var_name eq "RETVAL"; | |
444 | $var_types{$var_name} = $var_type; | |
ddf6bed1 IZ |
445 | # XXXX This check is a safeguard against the unfinished conversion of |
446 | # generate_init(). When generate_init() is fixed, | |
447 | # one can use 2-args map_type() unconditionally. | |
448 | if ($var_type =~ / \( \s* \* \s* \) /x) { | |
449 | # Function pointers are not yet supported with &output_init! | |
450 | print "\t" . &map_type($var_type, $var_name); | |
451 | $name_printed = 1; | |
452 | } else { | |
453 | print "\t" . &map_type($var_type); | |
454 | $name_printed = 0; | |
455 | } | |
8e07c86e | 456 | $var_num = $args_match{$var_name}; |
382b8d97 | 457 | |
0ab125c1 | 458 | $proto_arg[$var_num] = ProtoString($var_type) |
8fc38fda | 459 | if $var_num ; |
0f568861 | 460 | $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; |
f8b8e0a4 | 461 | if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ |
0f568861 | 462 | or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ |
f8b8e0a4 | 463 | and $var_init !~ /\S/) { |
ddf6bed1 IZ |
464 | if ($name_printed) { |
465 | print ";\n"; | |
466 | } else { | |
9bea678f | 467 | print "\t$var_name;\n"; |
ddf6bed1 | 468 | } |
8e07c86e | 469 | } elsif ($var_init =~ /\S/) { |
ddf6bed1 | 470 | &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); |
8e07c86e AD |
471 | } elsif ($var_num) { |
472 | # generate initialization code | |
ddf6bed1 | 473 | &generate_init($var_type, $var_num, $var_name, $name_printed); |
8e07c86e AD |
474 | } else { |
475 | print ";\n"; | |
476 | } | |
477 | } | |
478 | } | |
479 | ||
480 | sub OUTPUT_handler { | |
481 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
482 | next unless /\S/; | |
ef50df4b GS |
483 | if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { |
484 | $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); | |
485 | next; | |
486 | } | |
8e07c86e AD |
487 | my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; |
488 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next | |
489 | if $outargs{$outarg} ++ ; | |
490 | if (!$gotRETVAL and $outarg eq 'RETVAL') { | |
491 | # deal with RETVAL last | |
492 | $RETVAL_code = $outcode ; | |
493 | $gotRETVAL = 1 ; | |
494 | next ; | |
495 | } | |
496 | blurt ("Error: OUTPUT $outarg not an argument"), next | |
497 | unless defined($args_match{$outarg}); | |
498 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next | |
499 | unless defined $var_types{$outarg} ; | |
f78230ad | 500 | $var_num = $args_match{$outarg}; |
8e07c86e AD |
501 | if ($outcode) { |
502 | print "\t$outcode\n"; | |
f78230ad | 503 | print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; |
8e07c86e | 504 | } else { |
ef50df4b | 505 | &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); |
8e07c86e | 506 | } |
0ab125c1 | 507 | delete $in_out{$outarg} # No need to auto-OUTPUT |
0f568861 | 508 | if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; |
8e07c86e AD |
509 | } |
510 | } | |
511 | ||
cfc02341 IZ |
512 | sub C_ARGS_handler() { |
513 | my $in = merge_section(); | |
0ab125c1 | 514 | |
cfc02341 IZ |
515 | TrimWhitespace($in); |
516 | $func_args = $in; | |
0ab125c1 | 517 | } |
cfc02341 IZ |
518 | |
519 | sub INTERFACE_MACRO_handler() { | |
520 | my $in = merge_section(); | |
0ab125c1 | 521 | |
cfc02341 IZ |
522 | TrimWhitespace($in); |
523 | if ($in =~ /\s/) { # two | |
524 | ($interface_macro, $interface_macro_set) = split ' ', $in; | |
525 | } else { | |
526 | $interface_macro = $in; | |
527 | $interface_macro_set = 'UNKNOWN_CVT'; # catch later | |
528 | } | |
529 | $interface = 1; # local | |
530 | $Interfaces = 1; # global | |
531 | } | |
532 | ||
533 | sub INTERFACE_handler() { | |
534 | my $in = merge_section(); | |
0ab125c1 | 535 | |
cfc02341 | 536 | TrimWhitespace($in); |
0ab125c1 | 537 | |
cfc02341 IZ |
538 | foreach (split /[\s,]+/, $in) { |
539 | $Interfaces{$_} = $_; | |
540 | } | |
541 | print Q<<"EOF"; | |
542 | # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); | |
543 | EOF | |
544 | $interface = 1; # local | |
545 | $Interfaces = 1; # global | |
546 | } | |
547 | ||
0ab125c1 NIS |
548 | sub CLEANUP_handler() { print_section() } |
549 | sub PREINIT_handler() { print_section() } | |
550 | sub POSTCALL_handler() { print_section() } | |
551 | sub INIT_handler() { print_section() } | |
8fc38fda | 552 | |
8e07c86e AD |
553 | sub GetAliases |
554 | { | |
555 | my ($line) = @_ ; | |
556 | my ($orig) = $line ; | |
557 | my ($alias) ; | |
558 | my ($value) ; | |
559 | ||
560 | # Parse alias definitions | |
561 | # format is | |
562 | # alias = value alias = value ... | |
563 | ||
564 | while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { | |
565 | $alias = $1 ; | |
566 | $orig_alias = $alias ; | |
567 | $value = $2 ; | |
568 | ||
569 | # check for optional package definition in the alias | |
570 | $alias = $Packprefix . $alias if $alias !~ /::/ ; | |
0ab125c1 | 571 | |
8e07c86e AD |
572 | # check for duplicate alias name & duplicate value |
573 | Warn("Warning: Ignoring duplicate alias '$orig_alias'") | |
4230ab3f | 574 | if defined $XsubAliases{$alias} ; |
8e07c86e | 575 | |
4230ab3f | 576 | Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") |
577 | if $XsubAliasValues{$value} ; | |
8e07c86e | 578 | |
4230ab3f | 579 | $XsubAliases = 1; |
580 | $XsubAliases{$alias} = $value ; | |
581 | $XsubAliasValues{$value} = $orig_alias ; | |
8e07c86e AD |
582 | } |
583 | ||
584 | blurt("Error: Cannot parse ALIAS definitions from '$orig'") | |
585 | if $line ; | |
586 | } | |
587 | ||
be3174d2 GS |
588 | sub ATTRS_handler () |
589 | { | |
590 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
591 | next unless /\S/; | |
592 | TrimWhitespace($_) ; | |
593 | push @Attributes, $_; | |
594 | } | |
595 | } | |
596 | ||
382b8d97 | 597 | sub ALIAS_handler () |
8e07c86e AD |
598 | { |
599 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
600 | next unless /\S/; | |
601 | TrimWhitespace($_) ; | |
602 | GetAliases($_) if $_ ; | |
603 | } | |
604 | } | |
605 | ||
54162f5c JP |
606 | sub OVERLOAD_handler() |
607 | { | |
608 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
609 | next unless /\S/; | |
610 | TrimWhitespace($_) ; | |
964097f7 | 611 | while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { |
54162f5c JP |
612 | $Overload = 1 unless $Overload; |
613 | my $overload = "$Package\::(".$1 ; | |
614 | push(@InitFileCode, | |
615 | " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); | |
616 | } | |
617 | } | |
618 | ||
619 | } | |
620 | ||
30d6fba6 JP |
621 | sub FALLBACK_handler() |
622 | { | |
623 | # the rest of the current line should contain either TRUE, | |
624 | # FALSE or UNDEF | |
625 | ||
626 | TrimWhitespace($_) ; | |
627 | my %map = ( | |
628 | TRUE => "PL_sv_yes", 1 => "PL_sv_yes", | |
629 | FALSE => "PL_sv_no", 0 => "PL_sv_no", | |
630 | UNDEF => "PL_sv_undef", | |
631 | ) ; | |
632 | ||
633 | # check for valid FALLBACK value | |
634 | death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ; | |
635 | ||
636 | $Fallback = $map{uc $_} ; | |
637 | } | |
638 | ||
382b8d97 | 639 | sub REQUIRE_handler () |
8e07c86e AD |
640 | { |
641 | # the rest of the current line should contain a version number | |
642 | my ($Ver) = $_ ; | |
643 | ||
644 | TrimWhitespace($Ver) ; | |
645 | ||
646 | death ("Error: REQUIRE expects a version number") | |
647 | unless $Ver ; | |
648 | ||
649 | # check that the version number is of the form n.n | |
650 | death ("Error: REQUIRE: expected a number, got '$Ver'") | |
651 | unless $Ver =~ /^\d+(\.\d*)?/ ; | |
652 | ||
653 | death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") | |
0ab125c1 | 654 | unless $XSUBPP_version >= $Ver ; |
8e07c86e AD |
655 | } |
656 | ||
8fc38fda | 657 | sub VERSIONCHECK_handler () |
658 | { | |
659 | # the rest of the current line should contain either ENABLE or | |
660 | # DISABLE | |
0ab125c1 | 661 | |
8fc38fda | 662 | TrimWhitespace($_) ; |
0ab125c1 | 663 | |
8fc38fda | 664 | # check for ENABLE/DISABLE |
665 | death ("Error: VERSIONCHECK: ENABLE/DISABLE") | |
666 | unless /^(ENABLE|DISABLE)/i ; | |
0ab125c1 | 667 | |
8fc38fda | 668 | $WantVersionChk = 1 if $1 eq 'ENABLE' ; |
669 | $WantVersionChk = 0 if $1 eq 'DISABLE' ; | |
0ab125c1 | 670 | |
8fc38fda | 671 | } |
672 | ||
382b8d97 PM |
673 | sub PROTOTYPE_handler () |
674 | { | |
7d41bd0a PM |
675 | my $specified ; |
676 | ||
0ab125c1 | 677 | death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
c07a80fd | 678 | if $proto_in_this_xsub ++ ; |
679 | ||
382b8d97 PM |
680 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
681 | next unless /\S/; | |
7d41bd0a | 682 | $specified = 1 ; |
382b8d97 PM |
683 | TrimWhitespace($_) ; |
684 | if ($_ eq 'DISABLE') { | |
0ab125c1 | 685 | $ProtoThisXSUB = 0 |
382b8d97 PM |
686 | } |
687 | elsif ($_ eq 'ENABLE') { | |
0ab125c1 | 688 | $ProtoThisXSUB = 1 |
382b8d97 PM |
689 | } |
690 | else { | |
691 | # remove any whitespace | |
692 | s/\s+//g ; | |
693 | death("Error: Invalid prototype '$_'") | |
694 | unless ValidProtoString($_) ; | |
695 | $ProtoThisXSUB = C_string($_) ; | |
696 | } | |
697 | } | |
c07a80fd | 698 | |
7d41bd0a PM |
699 | # If no prototype specified, then assume empty prototype "" |
700 | $ProtoThisXSUB = 2 unless $specified ; | |
701 | ||
8fc38fda | 702 | $ProtoUsed = 1 ; |
c07a80fd | 703 | |
382b8d97 PM |
704 | } |
705 | ||
db3b9414 | 706 | sub SCOPE_handler () |
707 | { | |
0ab125c1 | 708 | death("Error: Only 1 SCOPE declaration allowed per xsub") |
db3b9414 | 709 | if $scope_in_this_xsub ++ ; |
710 | ||
711 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { | |
712 | next unless /\S/; | |
713 | TrimWhitespace($_) ; | |
714 | if ($_ =~ /^DISABLE/i) { | |
0ab125c1 | 715 | $ScopeThisXSUB = 0 |
db3b9414 | 716 | } |
717 | elsif ($_ =~ /^ENABLE/i) { | |
0ab125c1 | 718 | $ScopeThisXSUB = 1 |
db3b9414 | 719 | } |
720 | } | |
721 | ||
722 | } | |
723 | ||
382b8d97 PM |
724 | sub PROTOTYPES_handler () |
725 | { | |
726 | # the rest of the current line should contain either ENABLE or | |
0ab125c1 | 727 | # DISABLE |
382b8d97 PM |
728 | |
729 | TrimWhitespace($_) ; | |
730 | ||
731 | # check for ENABLE/DISABLE | |
732 | death ("Error: PROTOTYPES: ENABLE/DISABLE") | |
733 | unless /^(ENABLE|DISABLE)/i ; | |
734 | ||
735 | $WantPrototypes = 1 if $1 eq 'ENABLE' ; | |
736 | $WantPrototypes = 0 if $1 eq 'DISABLE' ; | |
8fc38fda | 737 | $ProtoUsed = 1 ; |
382b8d97 PM |
738 | |
739 | } | |
740 | ||
8fc38fda | 741 | sub INCLUDE_handler () |
742 | { | |
743 | # the rest of the current line should contain a valid filename | |
0ab125c1 | 744 | |
8fc38fda | 745 | TrimWhitespace($_) ; |
0ab125c1 | 746 | |
8fc38fda | 747 | death("INCLUDE: filename missing") |
748 | unless $_ ; | |
749 | ||
750 | death("INCLUDE: output pipe is illegal") | |
751 | if /^\s*\|/ ; | |
752 | ||
753 | # simple minded recursion detector | |
754 | death("INCLUDE loop detected") | |
755 | if $IncludedFiles{$_} ; | |
756 | ||
757 | ++ $IncludedFiles{$_} unless /\|\s*$/ ; | |
758 | ||
759 | # Save the current file context. | |
4230ab3f | 760 | push(@XSStack, { |
761 | type => 'file', | |
8fc38fda | 762 | LastLine => $lastline, |
763 | LastLineNo => $lastline_no, | |
764 | Line => \@line, | |
765 | LineNo => \@line_no, | |
766 | Filename => $filename, | |
c07a80fd | 767 | Handle => $FH, |
8fc38fda | 768 | }) ; |
0ab125c1 | 769 | |
c07a80fd | 770 | ++ $FH ; |
8fc38fda | 771 | |
772 | # open the new file | |
c07a80fd | 773 | open ($FH, "$_") or death("Cannot open '$_': $!") ; |
0ab125c1 | 774 | |
8fc38fda | 775 | print Q<<"EOF" ; |
776 | # | |
777 | #/* INCLUDE: Including '$_' from '$filename' */ | |
778 | # | |
779 | EOF | |
780 | ||
8fc38fda | 781 | $filename = $_ ; |
782 | ||
0ab125c1 | 783 | # Prime the pump by reading the first |
c07a80fd | 784 | # non-blank line |
785 | ||
786 | # skip leading blank lines | |
787 | while (<$FH>) { | |
788 | last unless /^\s*$/ ; | |
789 | } | |
790 | ||
791 | $lastline = $_ ; | |
8fc38fda | 792 | $lastline_no = $. ; |
0ab125c1 | 793 | |
8fc38fda | 794 | } |
0ab125c1 | 795 | |
8fc38fda | 796 | sub PopFile() |
797 | { | |
4230ab3f | 798 | return 0 unless $XSStack[-1]{type} eq 'file' ; |
799 | ||
800 | my $data = pop @XSStack ; | |
8fc38fda | 801 | my $ThisFile = $filename ; |
802 | my $isPipe = ($filename =~ /\|\s*$/) ; | |
0ab125c1 | 803 | |
8fc38fda | 804 | -- $IncludedFiles{$filename} |
805 | unless $isPipe ; | |
806 | ||
c07a80fd | 807 | close $FH ; |
8fc38fda | 808 | |
c07a80fd | 809 | $FH = $data->{Handle} ; |
8fc38fda | 810 | $filename = $data->{Filename} ; |
811 | $lastline = $data->{LastLine} ; | |
812 | $lastline_no = $data->{LastLineNo} ; | |
813 | @line = @{ $data->{Line} } ; | |
814 | @line_no = @{ $data->{LineNo} } ; | |
4230ab3f | 815 | |
8fc38fda | 816 | if ($isPipe and $? ) { |
817 | -- $lastline_no ; | |
818 | print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; | |
819 | exit 1 ; | |
820 | } | |
821 | ||
822 | print Q<<"EOF" ; | |
823 | # | |
824 | #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ | |
825 | # | |
826 | EOF | |
827 | ||
828 | return 1 ; | |
829 | } | |
830 | ||
382b8d97 PM |
831 | sub ValidProtoString ($) |
832 | { | |
833 | my($string) = @_ ; | |
834 | ||
835 | if ( $string =~ /^$proto_re+$/ ) { | |
836 | return $string ; | |
837 | } | |
838 | ||
839 | return 0 ; | |
840 | } | |
841 | ||
842 | sub C_string ($) | |
843 | { | |
844 | my($string) = @_ ; | |
845 | ||
846 | $string =~ s[\\][\\\\]g ; | |
847 | $string ; | |
848 | } | |
849 | ||
850 | sub ProtoString ($) | |
851 | { | |
852 | my ($type) = @_ ; | |
853 | ||
93d3b392 | 854 | $proto_letter{$type} or "\$" ; |
382b8d97 PM |
855 | } |
856 | ||
8e07c86e AD |
857 | sub check_cpp { |
858 | my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); | |
859 | if (@cpp) { | |
860 | my ($cpp, $cpplevel); | |
861 | for $cpp (@cpp) { | |
862 | if ($cpp =~ /^\#\s*if/) { | |
863 | $cpplevel++; | |
864 | } elsif (!$cpplevel) { | |
865 | Warn("Warning: #else/elif/endif without #if in this function"); | |
4230ab3f | 866 | print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" |
867 | if $XSStack[-1]{type} eq 'if'; | |
8e07c86e AD |
868 | return; |
869 | } elsif ($cpp =~ /^\#\s*endif/) { | |
870 | $cpplevel--; | |
871 | } | |
872 | } | |
873 | Warn("Warning: #if without #endif in this function") if $cpplevel; | |
874 | } | |
875 | } | |
876 | ||
877 | ||
8990e307 | 878 | sub Q { |
e50aee73 | 879 | my($text) = @_; |
4633a7c4 | 880 | $text =~ s/^#//gm; |
2304df62 AD |
881 | $text =~ s/\[\[/{/g; |
882 | $text =~ s/\]\]/}/g; | |
8990e307 | 883 | $text; |
93a17b20 LW |
884 | } |
885 | ||
c07a80fd | 886 | open($FH, $filename) or die "cannot open $filename: $!\n"; |
c2960299 | 887 | |
f06db76b | 888 | # Identify the version of xsubpp used |
f06db76b | 889 | print <<EOM ; |
e50aee73 | 890 | /* |
0ab125c1 | 891 | * This file was generated automatically by xsubpp version $XSUBPP_version from the |
93d3b392 | 892 | * contents of $filename. Do not edit this file, edit $filename instead. |
e50aee73 | 893 | * |
0ab125c1 | 894 | * ANY CHANGES MADE HERE WILL BE LOST! |
f06db76b AD |
895 | * |
896 | */ | |
e50aee73 | 897 | |
f06db76b | 898 | EOM |
0ab125c1 | 899 | |
6f1abe2b JT |
900 | |
901 | print("#line 1 \"$filename\"\n") | |
902 | if $WantLineNumbers; | |
f06db76b | 903 | |
e03d20b3 | 904 | firstmodule: |
c07a80fd | 905 | while (<$FH>) { |
e03d20b3 | 906 | if (/^=/) { |
7817ba4d | 907 | my $podstartline = $.; |
e03d20b3 | 908 | do { |
7817ba4d | 909 | if (/^=cut\s*$/) { |
1c2605dd NC |
910 | # We can't just write out a /* */ comment, as our embedded |
911 | # POD might itself be in a comment. We can't put a /**/ | |
912 | # comment inside #if 0, as the C standard says that the source | |
913 | # file is decomposed into preprocessing characters in the stage | |
914 | # before preprocessing commands are executed. | |
915 | # I don't want to leave the text as barewords, because the spec | |
916 | # isn't clear whether macros are expanded before or after | |
917 | # preprocessing commands are executed, and someone pathological | |
918 | # may just have defined one of the 3 words as a macro that does | |
919 | # something strange. Multiline strings are illegal in C, so | |
920 | # the "" we write must be a string literal. And they aren't | |
921 | # concatenated until 2 steps later, so we are safe. | |
922 | print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); | |
7817ba4d NC |
923 | printf("#line %d \"$filename\"\n", $. + 1) |
924 | if $WantLineNumbers; | |
925 | next firstmodule | |
926 | } | |
927 | ||
e03d20b3 | 928 | } while (<$FH>); |
7817ba4d NC |
929 | # At this point $. is at end of file so die won't state the start |
930 | # of the problem, and as we haven't yet read any lines &death won't | |
931 | # show the correct line in the message either. | |
932 | die ("Error: Unterminated pod in $filename, line $podstartline\n") | |
933 | unless $lastline; | |
e03d20b3 | 934 | } |
e50aee73 AD |
935 | last if ($Module, $Package, $Prefix) = |
936 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; | |
01f988be | 937 | |
a0d0e21e | 938 | print $_; |
93a17b20 | 939 | } |
e50aee73 AD |
940 | &Exit unless defined $_; |
941 | ||
cfc02341 IZ |
942 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
943 | ||
8fc38fda | 944 | $lastline = $_; |
945 | $lastline_no = $.; | |
93a17b20 | 946 | |
c07a80fd | 947 | # Read next xsub into @line from ($lastline, <$FH>). |
2304df62 AD |
948 | sub fetch_para { |
949 | # parse paragraph | |
4230ab3f | 950 | death ("Error: Unterminated `#if/#ifdef/#ifndef'") |
951 | if !defined $lastline && $XSStack[-1]{type} eq 'if'; | |
2304df62 | 952 | @line = (); |
c2960299 | 953 | @line_no = () ; |
4230ab3f | 954 | return PopFile() if !defined $lastline; |
e50aee73 AD |
955 | |
956 | if ($lastline =~ | |
957 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { | |
958 | $Module = $1; | |
8e07c86e AD |
959 | $Package = defined($2) ? $2 : ''; # keep -w happy |
960 | $Prefix = defined($3) ? $3 : ''; # keep -w happy | |
ff68c719 | 961 | $Prefix = quotemeta $Prefix ; |
e50aee73 | 962 | ($Module_cname = $Module) =~ s/\W/_/g; |
8e07c86e | 963 | ($Packid = $Package) =~ tr/:/_/; |
e50aee73 | 964 | $Packprefix = $Package; |
8e07c86e | 965 | $Packprefix .= "::" if $Packprefix ne ""; |
2304df62 | 966 | $lastline = ""; |
e50aee73 AD |
967 | } |
968 | ||
969 | for(;;) { | |
0ab125c1 | 970 | # Skip embedded PODs |
413e5597 | 971 | while ($lastline =~ /^=/) { |
e03d20b3 GS |
972 | while ($lastline = <$FH>) { |
973 | last if ($lastline =~ /^=cut\s*$/); | |
974 | } | |
975 | death ("Error: Unterminated pod") unless $lastline; | |
976 | $lastline = <$FH>; | |
977 | chomp $lastline; | |
978 | $lastline =~ s/^\s+$//; | |
979 | } | |
e50aee73 | 980 | if ($lastline !~ /^\s*#/ || |
4230ab3f | 981 | # CPP directives: |
982 | # ANSI: if ifdef ifndef elif else endif define undef | |
983 | # line error pragma | |
984 | # gcc: warning include_next | |
985 | # obj-c: import | |
986 | # others: ident (gcc notes that some cpps have this one) | |
987 | $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { | |
e50aee73 AD |
988 | last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; |
989 | push(@line, $lastline); | |
990 | push(@line_no, $lastline_no) ; | |
93a17b20 | 991 | } |
e50aee73 AD |
992 | |
993 | # Read next line and continuation lines | |
c07a80fd | 994 | last unless defined($lastline = <$FH>); |
e50aee73 AD |
995 | $lastline_no = $.; |
996 | my $tmp_line; | |
997 | $lastline .= $tmp_line | |
c07a80fd | 998 | while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); |
f8b8e0a4 | 999 | |
8e07c86e | 1000 | chomp $lastline; |
e50aee73 | 1001 | $lastline =~ s/^\s+$//; |
2304df62 | 1002 | } |
e50aee73 | 1003 | pop(@line), pop(@line_no) while @line && $line[-1] eq ""; |
e50aee73 | 1004 | 1; |
2304df62 | 1005 | } |
93a17b20 | 1006 | |
c2960299 | 1007 | PARAGRAPH: |
8e07c86e | 1008 | while (fetch_para()) { |
e50aee73 | 1009 | # Print initial preprocessor statements and blank lines |
4230ab3f | 1010 | while (@line && $line[0] !~ /^[^\#]/) { |
1011 | my $line = shift(@line); | |
1012 | print $line, "\n"; | |
1013 | next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; | |
1014 | my $statement = $+; | |
1015 | if ($statement eq 'if') { | |
1016 | $XSS_work_idx = @XSStack; | |
1017 | push(@XSStack, {type => 'if'}); | |
1018 | } else { | |
1019 | death ("Error: `$statement' with no matching `if'") | |
1020 | if $XSStack[-1]{type} ne 'if'; | |
1021 | if ($XSStack[-1]{varname}) { | |
1022 | push(@InitFileCode, "#endif\n"); | |
1023 | push(@BootCode, "#endif"); | |
1024 | } | |
1025 | ||
1026 | my(@fns) = keys %{$XSStack[-1]{functions}}; | |
1027 | if ($statement ne 'endif') { | |
1028 | # Hide the functions defined in other #if branches, and reset. | |
1029 | @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; | |
1030 | @{$XSStack[-1]}{qw(varname functions)} = ('', {}); | |
1031 | } else { | |
1032 | my($tmp) = pop(@XSStack); | |
1033 | 0 while (--$XSS_work_idx | |
1034 | && $XSStack[$XSS_work_idx]{type} ne 'if'); | |
1035 | # Keep all new defined functions | |
1036 | push(@fns, keys %{$tmp->{other_functions}}); | |
1037 | @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; | |
1038 | } | |
1039 | } | |
1040 | } | |
e50aee73 AD |
1041 | |
1042 | next PARAGRAPH unless @line; | |
1043 | ||
4230ab3f | 1044 | if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { |
1045 | # We are inside an #if, but have not yet #defined its xsubpp variable. | |
1046 | print "#define $cpp_next_tmp 1\n\n"; | |
1047 | push(@InitFileCode, "#if $cpp_next_tmp\n"); | |
1048 | push(@BootCode, "#if $cpp_next_tmp"); | |
1049 | $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; | |
1050 | } | |
1051 | ||
55497cff | 1052 | death ("Code is not inside a function" |
1053 | ." (maybe last function was ended by a blank line " | |
6d087280 | 1054 | ." followed by a statement on column one?)") |
e50aee73 AD |
1055 | if $line[0] =~ /^\s/; |
1056 | ||
2304df62 AD |
1057 | # initialize info arrays |
1058 | undef(%args_match); | |
1059 | undef(%var_types); | |
2304df62 AD |
1060 | undef(%defaults); |
1061 | undef($class); | |
1062 | undef($static); | |
1063 | undef($elipsis); | |
f06db76b | 1064 | undef($wantRETVAL) ; |
f8b8e0a4 | 1065 | undef($RETVAL_no_return) ; |
f06db76b | 1066 | undef(%arg_list) ; |
382b8d97 | 1067 | undef(@proto_arg) ; |
08ff138d IZ |
1068 | undef(@fake_INPUT_pre) ; # For length(s) generated variables |
1069 | undef(@fake_INPUT) ; | |
f8b8e0a4 | 1070 | undef($processing_arg_with_types) ; |
08ff138d | 1071 | undef(%argtype_seen) ; |
0f568861 | 1072 | undef(@outlist) ; |
f8b8e0a4 | 1073 | undef(%in_out) ; |
08ff138d IZ |
1074 | undef(%lengthof) ; |
1075 | # undef(%islengthof) ; | |
c07a80fd | 1076 | undef($proto_in_this_xsub) ; |
db3b9414 | 1077 | undef($scope_in_this_xsub) ; |
cfc02341 | 1078 | undef($interface); |
f8b8e0a4 | 1079 | undef($prepush_done); |
cfc02341 IZ |
1080 | $interface_macro = 'XSINTERFACE_FUNC' ; |
1081 | $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; | |
382b8d97 | 1082 | $ProtoThisXSUB = $WantPrototypes ; |
db3b9414 | 1083 | $ScopeThisXSUB = 0; |
f8b8e0a4 | 1084 | $xsreturn = 0; |
2304df62 | 1085 | |
8e07c86e | 1086 | $_ = shift(@line); |
30d6fba6 | 1087 | while ($kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) { |
8fc38fda | 1088 | &{"${kwd}_handler"}() ; |
8e07c86e AD |
1089 | next PARAGRAPH unless @line ; |
1090 | $_ = shift(@line); | |
1091 | } | |
c2960299 | 1092 | |
8e07c86e AD |
1093 | if (check_keyword("BOOT")) { |
1094 | &check_cpp; | |
6f1abe2b JT |
1095 | push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") |
1096 | if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; | |
1097 | push (@BootCode, @line, "") ; | |
c2960299 | 1098 | next PARAGRAPH ; |
a0d0e21e | 1099 | } |
c2960299 | 1100 | |
8e07c86e AD |
1101 | |
1102 | # extract return type, function name and arguments | |
cfc02341 | 1103 | ($ret_type) = TidyType($_); |
f8b8e0a4 | 1104 | $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; |
8e07c86e | 1105 | |
11416672 GS |
1106 | # Allow one-line ANSI-like declaration |
1107 | unshift @line, $2 | |
1108 | if $process_argtypes | |
1109 | and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; | |
1110 | ||
c2960299 AD |
1111 | # a function definition needs at least 2 lines |
1112 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH | |
1113 | unless @line ; | |
1114 | ||
8e07c86e AD |
1115 | $static = 1 if $ret_type =~ s/^static\s+//; |
1116 | ||
2304df62 | 1117 | $func_header = shift(@line); |
c2960299 | 1118 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
f8b8e0a4 | 1119 | unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; |
c2960299 | 1120 | |
8e07c86e | 1121 | ($class, $func_name, $orig_args) = ($1, $2, $3) ; |
f480b56a | 1122 | $class = "$4 $class" if $4; |
2304df62 | 1123 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
ff68c719 | 1124 | ($clean_func_name = $func_name) =~ s/^$Prefix//; |
1125 | $Full_func_name = "${Packid}_$clean_func_name"; | |
ff0cee69 | 1126 | if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } |
c2960299 AD |
1127 | |
1128 | # Check for duplicate function definition | |
4230ab3f | 1129 | for $tmp (@XSStack) { |
1130 | next unless defined $tmp->{functions}{$Full_func_name}; | |
ff68c719 | 1131 | Warn("Warning: duplicate function definition '$clean_func_name' detected"); |
4230ab3f | 1132 | last; |
8e07c86e | 1133 | } |
4230ab3f | 1134 | $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; |
be3174d2 | 1135 | %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); |
ef50df4b | 1136 | $DoSetMagic = 1; |
c2960299 | 1137 | |
f8b8e0a4 GS |
1138 | $orig_args =~ s/\\\s*/ /g; # process line continuations |
1139 | ||
08ff138d | 1140 | my %only_C_inlist; # Not in the signature of Perl function |
f8b8e0a4 GS |
1141 | if ($process_argtypes and $orig_args =~ /\S/) { |
1142 | my $args = "$orig_args ,"; | |
14455d6c GS |
1143 | if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { |
1144 | @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); | |
f8b8e0a4 GS |
1145 | for ( @args ) { |
1146 | s/^\s+//; | |
1147 | s/\s+$//; | |
08ff138d IZ |
1148 | my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; |
1149 | my ($pre, $name) = ($arg =~ /(.*?) \s* | |
1150 | \b ( \w+ | length\( \s*\w+\s* \) ) | |
1151 | \s* $ /x); | |
f8b8e0a4 GS |
1152 | next unless length $pre; |
1153 | my $out_type; | |
1154 | my $inout_var; | |
0f568861 | 1155 | if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { |
f8b8e0a4 | 1156 | my $type = $1; |
63385af5 | 1157 | $out_type = $type if $type ne 'IN'; |
0f568861 | 1158 | $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; |
08ff138d IZ |
1159 | $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; |
1160 | } | |
1161 | my $islength; | |
1162 | if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { | |
1163 | $name = "XSauto_length_of_$1"; | |
1164 | $islength = 1; | |
1165 | die "Default value on length() argument: `$_'" | |
1166 | if length $default; | |
f8b8e0a4 | 1167 | } |
08ff138d IZ |
1168 | if (length $pre or $islength) { # Has a type |
1169 | if ($islength) { | |
1170 | push @fake_INPUT_pre, $arg; | |
1171 | } else { | |
1172 | push @fake_INPUT, $arg; | |
1173 | } | |
f8b8e0a4 | 1174 | # warn "pushing '$arg'\n"; |
08ff138d IZ |
1175 | $argtype_seen{$name}++; |
1176 | $_ = "$name$default"; # Assigns to @args | |
f8b8e0a4 | 1177 | } |
08ff138d | 1178 | $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; |
0f568861 | 1179 | push @outlist, $name if $out_type =~ /OUTLIST$/; |
f8b8e0a4 GS |
1180 | $in_out{$name} = $out_type if $out_type; |
1181 | } | |
1182 | } else { | |
1183 | @args = split(/\s*,\s*/, $orig_args); | |
1184 | Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); | |
1185 | } | |
1186 | } else { | |
1187 | @args = split(/\s*,\s*/, $orig_args); | |
1188 | for (@args) { | |
0f568861 | 1189 | if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { |
f8b8e0a4 | 1190 | my $out_type = $1; |
63385af5 | 1191 | next if $out_type eq 'IN'; |
08ff138d | 1192 | $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; |
0f568861 | 1193 | push @outlist, $name if $out_type =~ /OUTLIST$/; |
f8b8e0a4 GS |
1194 | $in_out{$_} = $out_type; |
1195 | } | |
1196 | } | |
1197 | } | |
a0d0e21e | 1198 | if (defined($class)) { |
683d4eee JL |
1199 | my $arg0 = ((defined($static) or $func_name eq 'new') |
1200 | ? "CLASS" : "THIS"); | |
8e07c86e | 1201 | unshift(@args, $arg0); |
f8b8e0a4 | 1202 | ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; |
2304df62 | 1203 | } |
f8b8e0a4 GS |
1204 | my $extra_args = 0; |
1205 | @args_num = (); | |
1206 | $num_args = 0; | |
1207 | my $report_args = ''; | |
1208 | foreach $i (0 .. $#args) { | |
2304df62 AD |
1209 | if ($args[$i] =~ s/\.\.\.//) { |
1210 | $elipsis = 1; | |
f8b8e0a4 GS |
1211 | if ($args[$i] eq '' && $i == $#args) { |
1212 | $report_args .= ", ..."; | |
2304df62 AD |
1213 | pop(@args); |
1214 | last; | |
1215 | } | |
1216 | } | |
08ff138d | 1217 | if ($only_C_inlist{$args[$i]}) { |
f8b8e0a4 GS |
1218 | push @args_num, undef; |
1219 | } else { | |
1220 | push @args_num, ++$num_args; | |
1221 | $report_args .= ", $args[$i]"; | |
1222 | } | |
8e07c86e | 1223 | if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
f8b8e0a4 | 1224 | $extra_args++; |
2304df62 AD |
1225 | $args[$i] = $1; |
1226 | $defaults{$args[$i]} = $2; | |
1227 | $defaults{$args[$i]} =~ s/"/\\"/g; | |
1228 | } | |
93d3b392 | 1229 | $proto_arg[$i+1] = "\$" ; |
2304df62 | 1230 | } |
f8b8e0a4 GS |
1231 | $min_args = $num_args - $extra_args; |
1232 | $report_args =~ s/"/\\"/g; | |
1233 | $report_args =~ s/^,\s+//; | |
1234 | my @func_args = @args; | |
1235 | shift @func_args if defined($class); | |
1236 | ||
1237 | for (@func_args) { | |
1238 | s/^/&/ if $in_out{$_}; | |
2304df62 | 1239 | } |
f8b8e0a4 GS |
1240 | $func_args = join(", ", @func_args); |
1241 | @args_match{@args} = @args_num; | |
2304df62 | 1242 | |
8e07c86e | 1243 | $PPCODE = grep(/^\s*PPCODE\s*:/, @line); |
93d3b392 | 1244 | $CODE = grep(/^\s*CODE\s*:/, @line); |
6c5fb52b TB |
1245 | # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) |
1246 | # to set explicit return values. | |
1247 | $EXPLICIT_RETURN = ($CODE && | |
1248 | ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); | |
8e07c86e | 1249 | $ALIAS = grep(/^\s*ALIAS\s*:/, @line); |
cfc02341 | 1250 | $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); |
8e07c86e | 1251 | |
f8b8e0a4 GS |
1252 | $xsreturn = 1 if $EXPLICIT_RETURN; |
1253 | ||
2304df62 | 1254 | # print function header |
a0d0e21e | 1255 | print Q<<"EOF"; |
05ceb97a | 1256 | #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ |
ff68c719 | 1257 | #XS(XS_${Full_func_name}) |
2304df62 | 1258 | #[[ |
a0d0e21e | 1259 | # dXSARGS; |
93a17b20 | 1260 | EOF |
8e07c86e AD |
1261 | print Q<<"EOF" if $ALIAS ; |
1262 | # dXSI32; | |
1263 | EOF | |
cfc02341 IZ |
1264 | print Q<<"EOF" if $INTERFACE ; |
1265 | # dXSFUNCTION($ret_type); | |
1266 | EOF | |
2304df62 | 1267 | if ($elipsis) { |
8e07c86e | 1268 | $cond = ($min_args ? qq(items < $min_args) : 0); |
2304df62 AD |
1269 | } |
1270 | elsif ($min_args == $num_args) { | |
1271 | $cond = qq(items != $min_args); | |
1272 | } | |
1273 | else { | |
1274 | $cond = qq(items < $min_args || items > $num_args); | |
1275 | } | |
8990e307 | 1276 | |
2304df62 AD |
1277 | print Q<<"EOF" if $except; |
1278 | # char errbuf[1024]; | |
1279 | # *errbuf = '\0'; | |
1280 | EOF | |
1281 | ||
0ab125c1 | 1282 | if ($ALIAS) |
8e07c86e AD |
1283 | { print Q<<"EOF" if $cond } |
1284 | # if ($cond) | |
f8b8e0a4 | 1285 | # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); |
8e07c86e | 1286 | EOF |
0ab125c1 | 1287 | else |
8e07c86e AD |
1288 | { print Q<<"EOF" if $cond } |
1289 | # if ($cond) | |
f8b8e0a4 | 1290 | # Perl_croak(aTHX_ "Usage: $pname($report_args)"); |
93a17b20 LW |
1291 | EOF |
1292 | ||
349b520e DM |
1293 | #gcc -Wall: if an xsub has no arguments and PPCODE is used |
1294 | #it is likely none of ST, XSRETURN or XSprePUSH macros are used | |
1295 | #hence `ax' (setup by dXSARGS) is unused | |
1296 | #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS | |
1297 | #but such a move could break third-party extensions | |
1298 | print Q<<"EOF" if $PPCODE and $num_args == 0; | |
1299 | # PERL_UNUSED_VAR(ax); /* -Wall */ | |
1300 | EOF | |
1301 | ||
a0d0e21e LW |
1302 | print Q<<"EOF" if $PPCODE; |
1303 | # SP -= items; | |
1304 | EOF | |
1305 | ||
2304df62 | 1306 | # Now do a block of some sort. |
93a17b20 | 1307 | |
2304df62 | 1308 | $condnum = 0; |
8e07c86e AD |
1309 | $cond = ''; # last CASE: condidional |
1310 | push(@line, "$END:"); | |
1311 | push(@line_no, $line_no[-1]); | |
1312 | $_ = ''; | |
1313 | &check_cpp; | |
2304df62 | 1314 | while (@line) { |
8e07c86e AD |
1315 | &CASE_handler if check_keyword("CASE"); |
1316 | print Q<<"EOF"; | |
1317 | # $except [[ | |
93a17b20 LW |
1318 | EOF |
1319 | ||
1320 | # do initialization of input variables | |
1321 | $thisdone = 0; | |
1322 | $retvaldone = 0; | |
463ee0b2 | 1323 | $deferred = ""; |
c2960299 AD |
1324 | %arg_list = () ; |
1325 | $gotRETVAL = 0; | |
f06db76b | 1326 | |
8fc38fda | 1327 | INPUT_handler() ; |
54162f5c | 1328 | process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; |
8fc38fda | 1329 | |
db3b9414 | 1330 | print Q<<"EOF" if $ScopeThisXSUB; |
1331 | # ENTER; | |
1332 | # [[ | |
1333 | EOF | |
1334 | ||
a0d0e21e | 1335 | if (!$thisdone && defined($class)) { |
683d4eee | 1336 | if (defined($static) or $func_name eq 'new') { |
a0d0e21e LW |
1337 | print "\tchar *"; |
1338 | $var_types{"CLASS"} = "char *"; | |
1339 | &generate_init("char *", 1, "CLASS"); | |
1340 | } | |
1341 | else { | |
93a17b20 LW |
1342 | print "\t$class *"; |
1343 | $var_types{"THIS"} = "$class *"; | |
1344 | &generate_init("$class *", 1, "THIS"); | |
a0d0e21e | 1345 | } |
93a17b20 LW |
1346 | } |
1347 | ||
1348 | # do code | |
1349 | if (/^\s*NOT_IMPLEMENTED_YET/) { | |
cea2e8a9 | 1350 | print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; |
4633a7c4 | 1351 | $_ = '' ; |
93a17b20 LW |
1352 | } else { |
1353 | if ($ret_type ne "void") { | |
ddf6bed1 | 1354 | print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" |
93a17b20 LW |
1355 | if !$retvaldone; |
1356 | $args_match{"RETVAL"} = 0; | |
1357 | $var_types{"RETVAL"} = $ret_type; | |
b26a54d0 GS |
1358 | print "\tdXSTARG;\n" |
1359 | if $WantOptimize and $targetable{$type_kind{$ret_type}}; | |
93a17b20 | 1360 | } |
db3b9414 | 1361 | |
08ff138d IZ |
1362 | if (@fake_INPUT or @fake_INPUT_pre) { |
1363 | unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; | |
f8b8e0a4 GS |
1364 | $_ = ""; |
1365 | $processing_arg_with_types = 1; | |
1366 | INPUT_handler() ; | |
1367 | } | |
8e07c86e | 1368 | print $deferred; |
db3b9414 | 1369 | |
54162f5c | 1370 | process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; |
8e07c86e AD |
1371 | |
1372 | if (check_keyword("PPCODE")) { | |
8fc38fda | 1373 | print_section(); |
8e07c86e | 1374 | death ("PPCODE must be last thing") if @line; |
db3b9414 | 1375 | print "\tLEAVE;\n" if $ScopeThisXSUB; |
a0d0e21e | 1376 | print "\tPUTBACK;\n\treturn;\n"; |
8e07c86e | 1377 | } elsif (check_keyword("CODE")) { |
8fc38fda | 1378 | print_section() ; |
1379 | } elsif (defined($class) and $func_name eq "DESTROY") { | |
a0d0e21e | 1380 | print "\n\t"; |
8e07c86e | 1381 | print "delete THIS;\n"; |
93a17b20 LW |
1382 | } else { |
1383 | print "\n\t"; | |
1384 | if ($ret_type ne "void") { | |
463ee0b2 | 1385 | print "RETVAL = "; |
e50aee73 | 1386 | $wantRETVAL = 1; |
93a17b20 LW |
1387 | } |
1388 | if (defined($static)) { | |
683d4eee | 1389 | if ($func_name eq 'new') { |
8fc38fda | 1390 | $func_name = "$class"; |
8e07c86e AD |
1391 | } else { |
1392 | print "${class}::"; | |
a0d0e21e | 1393 | } |
93a17b20 | 1394 | } elsif (defined($class)) { |
683d4eee | 1395 | if ($func_name eq 'new') { |
8fc38fda | 1396 | $func_name .= " $class"; |
1397 | } else { | |
93a17b20 | 1398 | print "THIS->"; |
8fc38fda | 1399 | } |
93a17b20 | 1400 | } |
e50aee73 AD |
1401 | $func_name =~ s/^($spat)// |
1402 | if defined($spat); | |
cfc02341 | 1403 | $func_name = 'XSFUNCTION' if $interface; |
93a17b20 | 1404 | print "$func_name($func_args);\n"; |
93a17b20 LW |
1405 | } |
1406 | } | |
1407 | ||
1408 | # do output variables | |
f8b8e0a4 GS |
1409 | $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; |
1410 | undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); | |
1411 | # $wantRETVAL set if 'RETVAL =' autogenerated | |
1412 | ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; | |
8e07c86e | 1413 | undef %outargs ; |
54162f5c | 1414 | process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); |
f06db76b | 1415 | |
0f568861 IZ |
1416 | &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) |
1417 | for grep $in_out{$_} =~ /OUT$/, keys %in_out; | |
1418 | ||
f06db76b | 1419 | # all OUTPUT done, so now push the return value on the stack |
8e07c86e AD |
1420 | if ($gotRETVAL && $RETVAL_code) { |
1421 | print "\t$RETVAL_code\n"; | |
1422 | } elsif ($gotRETVAL || $wantRETVAL) { | |
b26a54d0 GS |
1423 | my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; |
1424 | my $var = 'RETVAL'; | |
1425 | my $type = $ret_type; | |
1426 | ||
1427 | # 0: type, 1: with_size, 2: how, 3: how_size | |
1428 | if ($t and not $t->[1] and $t->[0] eq 'p') { | |
1429 | # PUSHp corresponds to setpvn. Treate setpv directly | |
1430 | my $what = eval qq("$t->[2]"); | |
1431 | warn $@ if $@; | |
1432 | ||
1433 | print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; | |
f8b8e0a4 | 1434 | $prepush_done = 1; |
b26a54d0 GS |
1435 | } |
1436 | elsif ($t) { | |
1437 | my $what = eval qq("$t->[2]"); | |
1438 | warn $@ if $@; | |
1439 | ||
1440 | my $size = $t->[3]; | |
1441 | $size = '' unless defined $size; | |
1442 | $size = eval qq("$size"); | |
1443 | warn $@ if $@; | |
1444 | print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; | |
f8b8e0a4 | 1445 | $prepush_done = 1; |
b26a54d0 GS |
1446 | } |
1447 | else { | |
1448 | # RETVAL almost never needs SvSETMAGIC() | |
1449 | &generate_output($ret_type, 0, 'RETVAL', 0); | |
1450 | } | |
8e07c86e | 1451 | } |
f06db76b | 1452 | |
f8b8e0a4 GS |
1453 | $xsreturn = 1 if $ret_type ne "void"; |
1454 | my $num = $xsreturn; | |
0f568861 | 1455 | my $c = @outlist; |
f8b8e0a4 GS |
1456 | print "\tXSprePUSH;" if $c and not $prepush_done; |
1457 | print "\tEXTEND(SP,$c);\n" if $c; | |
1458 | $xsreturn += $c; | |
0f568861 | 1459 | generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; |
f8b8e0a4 | 1460 | |
93a17b20 | 1461 | # do cleanup |
54162f5c | 1462 | process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; |
8e07c86e | 1463 | |
db3b9414 | 1464 | print Q<<"EOF" if $ScopeThisXSUB; |
1465 | # ]] | |
1466 | EOF | |
1467 | print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; | |
1468 | # LEAVE; | |
1469 | EOF | |
1470 | ||
93a17b20 | 1471 | # print function trailer |
8e07c86e | 1472 | print Q<<EOF; |
2304df62 | 1473 | # ]] |
8e07c86e AD |
1474 | EOF |
1475 | print Q<<EOF if $except; | |
8990e307 LW |
1476 | # BEGHANDLERS |
1477 | # CATCHALL | |
1478 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); | |
1479 | # ENDHANDLERS | |
93a17b20 | 1480 | EOF |
8e07c86e AD |
1481 | if (check_keyword("CASE")) { |
1482 | blurt ("Error: No `CASE:' at top of function") | |
1483 | unless $condnum; | |
1484 | $_ = "CASE: $_"; # Restore CASE: label | |
1485 | next; | |
8990e307 | 1486 | } |
8e07c86e AD |
1487 | last if $_ eq "$END:"; |
1488 | death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); | |
2304df62 | 1489 | } |
a0d0e21e | 1490 | |
2304df62 AD |
1491 | print Q<<EOF if $except; |
1492 | # if (errbuf[0]) | |
cea2e8a9 | 1493 | # Perl_croak(aTHX_ errbuf); |
2304df62 | 1494 | EOF |
a0d0e21e | 1495 | |
f8b8e0a4 | 1496 | if ($xsreturn) { |
93d3b392 | 1497 | print Q<<EOF unless $PPCODE; |
f8b8e0a4 | 1498 | # XSRETURN($xsreturn); |
a0d0e21e | 1499 | EOF |
93d3b392 | 1500 | } else { |
1501 | print Q<<EOF unless $PPCODE; | |
1502 | # XSRETURN_EMPTY; | |
1503 | EOF | |
1504 | } | |
a0d0e21e | 1505 | |
2304df62 | 1506 | print Q<<EOF; |
2304df62 | 1507 | #]] |
8990e307 | 1508 | # |
93a17b20 | 1509 | EOF |
382b8d97 | 1510 | |
4230ab3f | 1511 | my $newXS = "newXS" ; |
1512 | my $proto = "" ; | |
1513 | ||
382b8d97 PM |
1514 | # Build the prototype string for the xsub |
1515 | if ($ProtoThisXSUB) { | |
4230ab3f | 1516 | $newXS = "newXSproto"; |
1517 | ||
6f1abe2b | 1518 | if ($ProtoThisXSUB eq 2) { |
4230ab3f | 1519 | # User has specified empty prototype |
1520 | $proto = ', ""' ; | |
1521 | } | |
6f1abe2b | 1522 | elsif ($ProtoThisXSUB ne 1) { |
7d41bd0a | 1523 | # User has specified a prototype |
4230ab3f | 1524 | $proto = ', "' . $ProtoThisXSUB . '"'; |
382b8d97 PM |
1525 | } |
1526 | else { | |
1527 | my $s = ';'; | |
1528 | if ($min_args < $num_args) { | |
0ab125c1 | 1529 | $s = ''; |
382b8d97 PM |
1530 | $proto_arg[$min_args] .= ";" ; |
1531 | } | |
0ab125c1 | 1532 | push @proto_arg, "$s\@" |
382b8d97 | 1533 | if $elipsis ; |
0ab125c1 | 1534 | |
4230ab3f | 1535 | $proto = ', "' . join ("", @proto_arg) . '"'; |
382b8d97 PM |
1536 | } |
1537 | } | |
1538 | ||
4230ab3f | 1539 | if (%XsubAliases) { |
0ab125c1 | 1540 | $XsubAliases{$pname} = 0 |
4230ab3f | 1541 | unless defined $XsubAliases{$pname} ; |
1542 | while ( ($name, $value) = each %XsubAliases) { | |
1543 | push(@InitFileCode, Q<<"EOF"); | |
1544 | # cv = newXS(\"$name\", XS_$Full_func_name, file); | |
1545 | # XSANY.any_i32 = $value ; | |
1546 | EOF | |
1547 | push(@InitFileCode, Q<<"EOF") if $proto; | |
1548 | # sv_setpv((SV*)cv$proto) ; | |
1549 | EOF | |
1550 | } | |
0ab125c1 | 1551 | } |
be3174d2 GS |
1552 | elsif (@Attributes) { |
1553 | push(@InitFileCode, Q<<"EOF"); | |
1554 | # cv = newXS(\"$pname\", XS_$Full_func_name, file); | |
1555 | # apply_attrs_string("$Package", cv, "@Attributes", 0); | |
1556 | EOF | |
1557 | } | |
cfc02341 IZ |
1558 | elsif ($interface) { |
1559 | while ( ($name, $value) = each %Interfaces) { | |
1560 | $name = "$Package\::$name" unless $name =~ /::/; | |
1561 | push(@InitFileCode, Q<<"EOF"); | |
1562 | # cv = newXS(\"$name\", XS_$Full_func_name, file); | |
1563 | # $interface_macro_set(cv,$value) ; | |
1564 | EOF | |
1565 | push(@InitFileCode, Q<<"EOF") if $proto; | |
1566 | # sv_setpv((SV*)cv$proto) ; | |
1567 | EOF | |
1568 | } | |
4230ab3f | 1569 | } |
1570 | else { | |
1571 | push(@InitFileCode, | |
1572 | " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); | |
1573 | } | |
93a17b20 LW |
1574 | } |
1575 | ||
30d6fba6 JP |
1576 | if ($Overload) # make it findable with fetchmethod |
1577 | { | |
1578 | ||
1579 | print Q<<"EOF"; | |
1580 | #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */ | |
1581 | #XS(XS_${Packid}_nil) | |
1582 | #{ | |
1583 | # XSRETURN_EMPTY; | |
1584 | #} | |
1585 | # | |
1586 | EOF | |
1587 | unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK"); | |
1588 | /* Making a sub named "${Package}::()" allows the package */ | |
1589 | /* to be findable via fetchmethod(), and causes */ | |
1590 | /* overload::Overloaded("${Package}") to return true. */ | |
1591 | newXS("${Package}::()", XS_${Packid}_nil, file$proto); | |
1592 | MAKE_FETCHMETHOD_WORK | |
1593 | } | |
1594 | ||
93a17b20 | 1595 | # print initialization routine |
7ee8c957 | 1596 | |
e3b8966e | 1597 | print Q<<"EOF"; |
e3b8966e GS |
1598 | ##ifdef __cplusplus |
1599 | #extern "C" | |
1600 | ##endif | |
7ee8c957 GS |
1601 | EOF |
1602 | ||
8990e307 | 1603 | print Q<<"EOF"; |
05ceb97a | 1604 | #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ |
a0d0e21e | 1605 | #XS(boot_$Module_cname) |
7ee8c957 GS |
1606 | EOF |
1607 | ||
7ee8c957 | 1608 | print Q<<"EOF"; |
2304df62 | 1609 | #[[ |
a0d0e21e | 1610 | # dXSARGS; |
c6c619a9 DM |
1611 | EOF |
1612 | ||
1613 | #-Wall: if there is no $Full_func_name there are no xsubs in this .xs | |
1614 | #so `file' is unused | |
1615 | print Q<<"EOF" if $Full_func_name; | |
8990e307 | 1616 | # char* file = __FILE__; |
93a17b20 LW |
1617 | EOF |
1618 | ||
c6c619a9 DM |
1619 | print Q "#\n"; |
1620 | ||
8fc38fda | 1621 | print Q<<"EOF" if $WantVersionChk ; |
1622 | # XS_VERSION_BOOTCHECK ; | |
1623 | # | |
1624 | EOF | |
1625 | ||
cfc02341 | 1626 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e AD |
1627 | # { |
1628 | # CV * cv ; | |
1629 | # | |
1630 | EOF | |
1631 | ||
54162f5c | 1632 | print Q<<"EOF" if ($Overload); |
30d6fba6 JP |
1633 | # /* register the overloading (type 'A') magic */ |
1634 | # PL_amagic_generation++; | |
1635 | # /* The magic for overload gets a GV* via gv_fetchmeth as */ | |
1636 | # /* mentioned above, and looks in the SV* slot of it for */ | |
1637 | # /* the "fallback" status. */ | |
1638 | # sv_setsv( | |
1639 | # get_sv( "${Package}::()", TRUE ), | |
1640 | # $Fallback | |
1641 | # ); | |
54162f5c JP |
1642 | EOF |
1643 | ||
4230ab3f | 1644 | print @InitFileCode; |
a0d0e21e | 1645 | |
cfc02341 | 1646 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e AD |
1647 | # } |
1648 | EOF | |
1649 | ||
a0d0e21e LW |
1650 | if (@BootCode) |
1651 | { | |
6f1abe2b JT |
1652 | print "\n /* Initialisation Section */\n\n" ; |
1653 | @line = @BootCode; | |
1654 | print_section(); | |
8e07c86e | 1655 | print "\n /* End of Initialisation Section */\n\n" ; |
93a17b20 | 1656 | } |
a0d0e21e | 1657 | |
e50aee73 | 1658 | print Q<<"EOF";; |
3280af22 | 1659 | # XSRETURN_YES; |
e50aee73 | 1660 | #]] |
e3b8966e GS |
1661 | # |
1662 | EOF | |
1663 | ||
0ab125c1 | 1664 | warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") |
8fc38fda | 1665 | unless $ProtoUsed ; |
e50aee73 AD |
1666 | &Exit; |
1667 | ||
93a17b20 | 1668 | sub output_init { |
ddf6bed1 | 1669 | local($type, $num, $var, $init, $name_printed) = @_; |
a0d0e21e | 1670 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 | 1671 | |
7ad6fb0b | 1672 | if( $init =~ /^=/ ) { |
ddf6bed1 IZ |
1673 | if ($name_printed) { |
1674 | eval qq/print " $init\\n"/; | |
1675 | } else { | |
1676 | eval qq/print "\\t$var $init\\n"/; | |
1677 | } | |
7ad6fb0b TM |
1678 | warn $@ if $@; |
1679 | } else { | |
1680 | if( $init =~ s/^\+// && $num ) { | |
ddf6bed1 IZ |
1681 | &generate_init($type, $num, $var, $name_printed); |
1682 | } elsif ($name_printed) { | |
1683 | print ";\n"; | |
1684 | $init =~ s/^;//; | |
7ad6fb0b TM |
1685 | } else { |
1686 | eval qq/print "\\t$var;\\n"/; | |
1687 | warn $@ if $@; | |
1688 | $init =~ s/^;//; | |
1689 | } | |
1690 | $deferred .= eval qq/"\\n\\t$init\\n"/; | |
1691 | warn $@ if $@; | |
1692 | } | |
93a17b20 LW |
1693 | } |
1694 | ||
c2960299 AD |
1695 | sub Warn |
1696 | { | |
1697 | # work out the line number | |
1698 | my $line_no = $line_no[@line_no - @line -1] ; | |
0ab125c1 | 1699 | |
c2960299 AD |
1700 | print STDERR "@_ in $filename, line $line_no\n" ; |
1701 | } | |
1702 | ||
0ab125c1 NIS |
1703 | sub blurt |
1704 | { | |
c2960299 | 1705 | Warn @_ ; |
0ab125c1 | 1706 | $errors ++ |
c2960299 AD |
1707 | } |
1708 | ||
1709 | sub death | |
1710 | { | |
1711 | Warn @_ ; | |
1712 | exit 1 ; | |
1713 | } | |
8990e307 | 1714 | |
93a17b20 | 1715 | sub generate_init { |
2304df62 | 1716 | local($type, $num, $var) = @_; |
a0d0e21e | 1717 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 AD |
1718 | local($argoff) = $num - 1; |
1719 | local($ntype); | |
1720 | local($tk); | |
93a17b20 | 1721 | |
f06db76b | 1722 | $type = TidyType($type) ; |
0ab125c1 | 1723 | blurt("Error: '$type' not in typemap"), return |
c2960299 AD |
1724 | unless defined($type_kind{$type}); |
1725 | ||
2304df62 | 1726 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
8e07c86e | 1727 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 AD |
1728 | $tk = $type_kind{$type}; |
1729 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; | |
08ff138d IZ |
1730 | if ($tk eq 'T_PV' and exists $lengthof{$var}) { |
1731 | print "\t$var" unless $name_printed; | |
1732 | print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; | |
1733 | die "default value not supported with length(NAME) supplied" | |
1734 | if defined $defaults{$var}; | |
1735 | return; | |
1736 | } | |
0ab125c1 | 1737 | $type =~ tr/:/_/ unless $hiertype; |
615ca1f4 | 1738 | blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return |
c2960299 | 1739 | unless defined $input_expr{$tk} ; |
2304df62 AD |
1740 | $expr = $input_expr{$tk}; |
1741 | if ($expr =~ /DO_ARRAY_ELEM/) { | |
0ab125c1 | 1742 | blurt("Error: '$subtype' not in typemap"), return |
c2960299 | 1743 | unless defined($type_kind{$subtype}); |
615ca1f4 | 1744 | blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return |
c2960299 | 1745 | unless defined $input_expr{$type_kind{$subtype}} ; |
2304df62 | 1746 | $subexpr = $input_expr{$type_kind{$subtype}}; |
f8c11764 | 1747 | $subexpr =~ s/\$type/\$subtype/g; |
2304df62 AD |
1748 | $subexpr =~ s/ntype/subtype/g; |
1749 | $subexpr =~ s/\$arg/ST(ix_$var)/g; | |
1750 | $subexpr =~ s/\n\t/\n\t\t/g; | |
93d3b392 | 1751 | $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e | 1752 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 AD |
1753 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1754 | } | |
db3b9414 | 1755 | if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments |
1756 | $ScopeThisXSUB = 1; | |
1757 | } | |
2304df62 AD |
1758 | if (defined($defaults{$var})) { |
1759 | $expr =~ s/(\t+)/$1 /g; | |
1760 | $expr =~ s/ /\t/g; | |
ddf6bed1 IZ |
1761 | if ($name_printed) { |
1762 | print ";\n"; | |
1763 | } else { | |
1764 | eval qq/print "\\t$var;\\n"/; | |
1765 | warn $@ if $@; | |
1766 | } | |
a104f515 | 1767 | if ($defaults{$var} eq 'NO_INIT') { |
4628e4f8 GS |
1768 | $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; |
1769 | } else { | |
1770 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; | |
1771 | } | |
7ad6fb0b | 1772 | warn $@ if $@; |
08ff138d | 1773 | } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { |
ddf6bed1 IZ |
1774 | if ($name_printed) { |
1775 | print ";\n"; | |
1776 | } else { | |
1777 | eval qq/print "\\t$var;\\n"/; | |
1778 | warn $@ if $@; | |
1779 | } | |
2304df62 | 1780 | $deferred .= eval qq/"\\n$expr;\\n"/; |
7ad6fb0b | 1781 | warn $@ if $@; |
2304df62 | 1782 | } else { |
ddf6bed1 IZ |
1783 | die "panic: do not know how to handle this branch for function pointers" |
1784 | if $name_printed; | |
2304df62 | 1785 | eval qq/print "$expr;\\n"/; |
7ad6fb0b | 1786 | warn $@ if $@; |
2304df62 | 1787 | } |
93a17b20 LW |
1788 | } |
1789 | ||
1790 | sub generate_output { | |
f8b8e0a4 | 1791 | local($type, $num, $var, $do_setmagic, $do_push) = @_; |
a0d0e21e | 1792 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 AD |
1793 | local($argoff) = $num - 1; |
1794 | local($ntype); | |
93a17b20 | 1795 | |
f06db76b | 1796 | $type = TidyType($type) ; |
2304df62 | 1797 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
f8c11764 | 1798 | print "\t$arg = sv_newmortal();\n"; |
4bd3d083 | 1799 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; |
ef50df4b | 1800 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2304df62 | 1801 | } else { |
f06db76b | 1802 | blurt("Error: '$type' not in typemap"), return |
2304df62 | 1803 | unless defined($type_kind{$type}); |
615ca1f4 | 1804 | blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return |
c2960299 | 1805 | unless defined $output_expr{$type_kind{$type}} ; |
2304df62 AD |
1806 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
1807 | $ntype =~ s/\(\)//g; | |
8e07c86e | 1808 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 AD |
1809 | $expr = $output_expr{$type_kind{$type}}; |
1810 | if ($expr =~ /DO_ARRAY_ELEM/) { | |
c2960299 AD |
1811 | blurt("Error: '$subtype' not in typemap"), return |
1812 | unless defined($type_kind{$subtype}); | |
615ca1f4 | 1813 | blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return |
c2960299 | 1814 | unless defined $output_expr{$type_kind{$subtype}} ; |
2304df62 AD |
1815 | $subexpr = $output_expr{$type_kind{$subtype}}; |
1816 | $subexpr =~ s/ntype/subtype/g; | |
1817 | $subexpr =~ s/\$arg/ST(ix_$var)/g; | |
1818 | $subexpr =~ s/\$var/${var}[ix_$var]/g; | |
1819 | $subexpr =~ s/\n\t/\n\t\t/g; | |
1820 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; | |
a0d0e21e | 1821 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1822 | warn $@ if $@; |
ef50df4b | 1823 | print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
2304df62 | 1824 | } |
a0d0e21e | 1825 | elsif ($var eq 'RETVAL') { |
a2baab1c IZ |
1826 | if ($expr =~ /^\t\$arg = new/) { |
1827 | # We expect that $arg has refcnt 1, so we need to | |
1828 | # mortalize it. | |
a0d0e21e | 1829 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1830 | warn $@ if $@; |
f8b8e0a4 GS |
1831 | print "\tsv_2mortal(ST($num));\n"; |
1832 | print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; | |
93a17b20 | 1833 | } |
a2baab1c IZ |
1834 | elsif ($expr =~ /^\s*\$arg\s*=/) { |
1835 | # We expect that $arg has refcnt >=1, so we need | |
d689ffdd | 1836 | # to mortalize it! |
a2baab1c | 1837 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1838 | warn $@ if $@; |
d689ffdd | 1839 | print "\tsv_2mortal(ST(0));\n"; |
ef50df4b | 1840 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
a2baab1c | 1841 | } |
2304df62 | 1842 | else { |
a2baab1c IZ |
1843 | # Just hope that the entry would safely write it |
1844 | # over an already mortalized value. By | |
1845 | # coincidence, something like $arg = &sv_undef | |
1846 | # works too. | |
8990e307 | 1847 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e | 1848 | eval "print qq\a$expr\a"; |
7ad6fb0b | 1849 | warn $@ if $@; |
ef50df4b | 1850 | # new mortals don't have set magic |
463ee0b2 | 1851 | } |
2304df62 | 1852 | } |
f8b8e0a4 GS |
1853 | elsif ($do_push) { |
1854 | print "\tPUSHs(sv_newmortal());\n"; | |
1855 | $arg = "ST($num)"; | |
1856 | eval "print qq\a$expr\a"; | |
1857 | warn $@ if $@; | |
1858 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; | |
1859 | } | |
a0d0e21e LW |
1860 | elsif ($arg =~ /^ST\(\d+\)$/) { |
1861 | eval "print qq\a$expr\a"; | |
7ad6fb0b | 1862 | warn $@ if $@; |
ef50df4b | 1863 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
a0d0e21e | 1864 | } |
2304df62 | 1865 | } |
93a17b20 LW |
1866 | } |
1867 | ||
1868 | sub map_type { | |
ddf6bed1 | 1869 | my($type, $varname) = @_; |
93a17b20 | 1870 | |
0ab125c1 NIS |
1871 | # C++ has :: in types too so skip this |
1872 | $type =~ tr/:/_/ unless $hiertype; | |
8e07c86e | 1873 | $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; |
ddf6bed1 IZ |
1874 | if ($varname) { |
1875 | if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { | |
1876 | (substr $type, pos $type, 0) = " $varname "; | |
1877 | } else { | |
1878 | $type .= "\t$varname"; | |
1879 | } | |
1880 | } | |
8e07c86e | 1881 | $type; |
93a17b20 | 1882 | } |
8990e307 | 1883 | |
e50aee73 AD |
1884 | |
1885 | sub Exit { | |
ff0cee69 | 1886 | # If this is VMS, the exit status has meaning to the shell, so we |
1887 | # use a predictable value (SS$_Normal or SS$_Abort) rather than an | |
1888 | # arbitrary number. | |
1889 | # exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; | |
1890 | exit ($errors ? 1 : 0); | |
e50aee73 | 1891 | } |