Commit | Line | Data |
---|---|---|
5f05dabc | 1 | #!/usr/bin/perl -w |
f1e99d0d | 2 | # |
6294c161 DM |
3 | # Regenerate (overwriting only if changed): |
4 | # | |
5 | # embed.h | |
6 | # embedvar.h | |
6294c161 DM |
7 | # proto.h |
8 | # | |
9 | # from information stored in | |
10 | # | |
11 | # embed.fnc | |
12 | # intrpvar.h | |
13 | # perlvars.h | |
897d3989 | 14 | # regen/opcodes |
6294c161 | 15 | # |
6294c161 DM |
16 | # Accepts the standard regen_lib -q and -v args. |
17 | # | |
18 | # This script is normally invoked from regen.pl. | |
e50aee73 | 19 | |
69e2d40a | 20 | require 5.004; # keep this compatible, an old perl is all we may have before |
954c1994 | 21 | # we build the new one |
5f05dabc | 22 | |
88e01c9d AL |
23 | use strict; |
24 | ||
36bb303b NC |
25 | BEGIN { |
26 | # Get function prototypes | |
3d7c117d MB |
27 | require './regen/regen_lib.pl'; |
28 | require './regen/embed_lib.pl'; | |
36bb303b NC |
29 | } |
30 | ||
916e4025 | 31 | my $unflagged_pointers; |
69e2d40a | 32 | my @az = ('a'..'z'); |
88e01c9d | 33 | |
cea2e8a9 | 34 | # |
346f75ff | 35 | # See database of global and static function prototypes in embed.fnc |
cea2e8a9 GS |
36 | # This is used to generate prototype headers under various configurations, |
37 | # export symbols lists for different platforms, and macros to provide an | |
38 | # implicit interpreter context argument. | |
39 | # | |
40 | ||
eeec122d KW |
41 | my $error_count = 0; |
42 | sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't | |
43 | # succeed. | |
44 | warn shift; | |
45 | $error_count++; | |
46 | } | |
47 | ||
03b6588a | 48 | sub full_name ($$) { # Returns the function name with potentially the |
9824c081 | 49 | # prefixes 'S_' or 'Perl_' |
03b6588a KW |
50 | my ($func, $flags) = @_; |
51 | ||
c43e2db5 | 52 | return "Perl_$func" if $flags =~ /[ps]/; |
f1e99d0d | 53 | return "S_$func" if $flags =~ /[SIi]/; |
03b6588a KW |
54 | return $func; |
55 | } | |
56 | ||
5f8dc073 | 57 | sub open_print_header { |
56fd1190 | 58 | my ($file, $quote) = @_; |
4373e329 | 59 | |
5f8dc073 | 60 | return open_new($file, '>', |
9824c081 | 61 | { file => $file, style => '*', by => 'regen/embed.pl', |
69e2d40a YO |
62 | from => [ |
63 | 'embed.fnc', | |
64 | 'intrpvar.h', | |
65 | 'perlvars.h', | |
66 | 'regen/opcodes', | |
67 | 'regen/embed.pl', | |
68 | 'regen/embed_lib.pl', | |
69 | 'regen/HeaderParser.pm', | |
70 | ], | |
9824c081 | 71 | final => "\nEdit those files and run 'make regen_headers' to effect changes.\n", |
69e2d40a YO |
72 | copyright => [1993 .. 2022], |
73 | quote => $quote }); | |
5f8dc073 | 74 | } |
7f1be197 | 75 | |
69e2d40a YO |
76 | |
77 | sub open_buf_out { | |
78 | $_[0] //= ""; | |
79 | open my $fh,">", \$_[0] | |
80 | or die "Failed to open buffer: $!"; | |
81 | return $fh; | |
82 | } | |
5ccbf88e | 83 | |
cea2e8a9 | 84 | # generate proto.h |
69e2d40a YO |
85 | sub generate_proto_h { |
86 | my ($all)= @_; | |
87 | my $pr = open_buf_out(my $proto_buffer); | |
f8394530 | 88 | my $ret; |
9516dc40 | 89 | |
69e2d40a YO |
90 | foreach (@$all) { |
91 | if ($_->{type} ne "content") { | |
92 | print $pr "$_->{line}"; | |
9824c081 MS |
93 | next; |
94 | } | |
69e2d40a YO |
95 | my $embed= $_->{embed} |
96 | or next; | |
9516dc40 | 97 | |
69e2d40a YO |
98 | my $level= $_->{level}; |
99 | my $ind= $level ? " " : ""; | |
100 | $ind .= " " x ($level-1) if $level>1; | |
101 | my $inner_ind= $ind ? " " : " "; | |
102 | ||
103 | my ($flags,$retval,$plain_func,$args) = @{$embed}{qw(flags return_type name args)}; | |
c43e2db5 | 104 | if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx;] ) /x) { |
9824c081 MS |
105 | die_at_end "flag $1 is not legal (for function $plain_func)"; |
106 | } | |
107 | my @nonnull; | |
108 | my $args_assert_line = ( $flags !~ /G/ ); | |
21553840 | 109 | my $has_depth = ( $flags =~ /W/ ); |
9824c081 MS |
110 | my $has_context = ( $flags !~ /T/ ); |
111 | my $never_returns = ( $flags =~ /r/ ); | |
112 | my $binarycompat = ( $flags =~ /b/ ); | |
113 | my $commented_out = ( $flags =~ /m/ ); | |
114 | my $is_malloc = ( $flags =~ /a/ ); | |
115 | my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc; | |
116 | my @names_of_nn; | |
117 | my $func; | |
118 | ||
119 | if (! $can_ignore && $retval eq 'void') { | |
120 | warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked"; | |
121 | } | |
122 | ||
123 | die_at_end "$plain_func: S and p flags are mutually exclusive" | |
124 | if $flags =~ /S/ && $flags =~ /p/; | |
125 | die_at_end "$plain_func: m and $1 flags are mutually exclusive" | |
126 | if $flags =~ /m/ && $flags =~ /([pS])/; | |
127 | ||
128 | die_at_end "$plain_func: u flag only usable with m" if $flags =~ /u/ | |
129 | && $flags !~ /m/; | |
130 | ||
6abce846 YO |
131 | my ($static_flag, @extra_static_flags)= do { |
132 | # the seen filter can be removed once flag dedupe | |
133 | # is done in tidy_embed.pl | |
134 | my %seen; | |
135 | grep !$seen{$_}++, $flags =~/([SsIi])/g; | |
136 | }; | |
137 | ||
138 | if (@extra_static_flags) { | |
139 | my $flags_str = join ", ", $static_flag, @extra_static_flags; | |
140 | $flags_str =~ s/, (\w)\z/ and $1/; | |
141 | die_at_end "$plain_func: flags $flags_str are mutually exclusive\n"; | |
142 | } | |
143 | ||
9824c081 | 144 | my $static_inline = 0; |
6abce846 | 145 | if ($static_flag) { |
9824c081 MS |
146 | my $type; |
147 | if ($never_returns) { | |
148 | $type = { | |
149 | 'S' => 'PERL_STATIC_NO_RET', | |
c43e2db5 | 150 | 's' => 'PERL_STATIC_NO_RET', |
9824c081 MS |
151 | 'i' => 'PERL_STATIC_INLINE_NO_RET', |
152 | 'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET' | |
6abce846 | 153 | }->{$static_flag}; |
9824c081 MS |
154 | } |
155 | else { | |
156 | $type = { | |
157 | 'S' => 'STATIC', | |
c43e2db5 | 158 | 's' => 'STATIC', |
9824c081 MS |
159 | 'i' => 'PERL_STATIC_INLINE', |
160 | 'I' => 'PERL_STATIC_FORCE_INLINE' | |
6abce846 | 161 | }->{$static_flag}; |
9824c081 MS |
162 | } |
163 | $retval = "$type $retval"; | |
164 | die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/; | |
165 | $static_inline = $type =~ /^PERL_STATIC(?:_FORCE)?_INLINE/; | |
166 | } | |
167 | else { | |
168 | if ($never_returns) { | |
169 | $retval = "PERL_CALLCONV_NO_RET $retval"; | |
170 | } | |
171 | else { | |
172 | $retval = "PERL_CALLCONV $retval"; | |
173 | } | |
174 | } | |
175 | ||
3f394718 KW |
176 | $func = full_name($plain_func, $flags); |
177 | ||
9824c081 MS |
178 | die_at_end "For '$plain_func', M flag requires p flag" |
179 | if $flags =~ /M/ && $flags !~ /p/; | |
69e2d40a | 180 | my $C_required_flags = '[pIimbs]'; |
07b6261f | 181 | die_at_end |
69e2d40a YO |
182 | "For '$plain_func', C flag requires one of $C_required_flags] flags" |
183 | if $flags =~ /C/ | |
184 | && ($flags !~ /$C_required_flags/ | |
07b6261f | 185 | |
69e2d40a YO |
186 | # Notwithstanding the |
187 | # above, if the name won't | |
188 | # clash with a user name, | |
189 | # it's ok. | |
190 | && $plain_func !~ /^[Pp]erl/); | |
3f394718 | 191 | |
9824c081 MS |
192 | die_at_end "For '$plain_func', X flag requires one of [Iip] flags" |
193 | if $flags =~ /X/ && $flags !~ /[Iip]/; | |
194 | die_at_end "For '$plain_func', X and m flags are mutually exclusive" | |
195 | if $flags =~ /X/ && $flags =~ /m/; | |
196 | die_at_end "For '$plain_func', [Ii] with [ACX] requires p flag" | |
197 | if $flags =~ /[Ii]/ && $flags =~ /[ACX]/ && $flags !~ /p/; | |
198 | die_at_end "For '$plain_func', b and m flags are mutually exclusive" | |
199 | . " (try M flag)" if $flags =~ /b/ && $flags =~ /m/; | |
200 | die_at_end "For '$plain_func', b flag without M flag requires D flag" | |
201 | if $flags =~ /b/ && $flags !~ /M/ && $flags !~ /D/; | |
202 | die_at_end "For '$plain_func', I and i flags are mutually exclusive" | |
203 | if $flags =~ /I/ && $flags =~ /i/; | |
204 | ||
9824c081 | 205 | $ret = ""; |
69e2d40a YO |
206 | $ret .= "$retval\n"; |
207 | $ret .= "$func("; | |
9824c081 | 208 | if ( $has_context ) { |
69e2d40a | 209 | $ret .= @$args ? "pTHX_ " : "pTHX"; |
9824c081 | 210 | } |
69e2d40a | 211 | if (@$args) { |
9824c081 MS |
212 | die_at_end "n flag is contradicted by having arguments" |
213 | if $flags =~ /n/; | |
214 | my $n; | |
69e2d40a | 215 | for my $arg ( @$args ) { |
9824c081 | 216 | ++$n; |
69e2d40a YO |
217 | if ($arg =~ / ^ " (.+) " $ /x) { # Handle literal string |
218 | my $name = $1; | |
219 | ||
220 | # Make the string a legal C identifier; 'p' is arbitrary, | |
221 | # and is because C reserves leading underscores | |
222 | $name =~ s/^\W/p/a; | |
223 | $name =~ s/\W/_/ag; | |
224 | ||
225 | $arg = "const char * const $name"; | |
226 | die_at_end 'm flag required for "literal" argument' | |
227 | unless $flags =~ /m/; | |
228 | } | |
229 | elsif ( $args_assert_line | |
230 | && $arg =~ /\*/ | |
231 | && $arg !~ /\b(NN|NULLOK)\b/ ) | |
232 | { | |
9824c081 MS |
233 | warn "$func: $arg needs NN or NULLOK\n"; |
234 | ++$unflagged_pointers; | |
235 | } | |
236 | my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); | |
237 | push( @nonnull, $n ) if $nn; | |
cc8af694 | 238 | my $nz = ( $arg =~ s/\s*\bNZ\b\s+// ); |
9824c081 MS |
239 | |
240 | my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect | |
241 | ||
242 | # Make sure each arg has at least a type and a var name. | |
243 | # An arg of "int" is valid C, but want it to be "int foo". | |
244 | my $temp_arg = $arg; | |
245 | $temp_arg =~ s/\*//g; | |
246 | $temp_arg =~ s/\s*\bstruct\b\s*/ /g; | |
247 | if ( ($temp_arg ne "...") | |
248 | && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { | |
249 | die_at_end "$func: $arg ($n) doesn't have a name\n"; | |
250 | } | |
cc8af694 | 251 | if (defined $1 && ($nn||$nz) && !($commented_out && !$binarycompat)) { |
9824c081 MS |
252 | push @names_of_nn, $1; |
253 | } | |
254 | } | |
69e2d40a | 255 | $ret .= join ", ", @$args; |
9824c081 MS |
256 | } |
257 | else { | |
258 | $ret .= "void" if !$has_context; | |
259 | } | |
21553840 | 260 | $ret .= " _pDEPTH" if $has_depth; |
9824c081 MS |
261 | $ret .= ")"; |
262 | my @attrs; | |
263 | if ( $flags =~ /r/ ) { | |
264 | push @attrs, "__attribute__noreturn__"; | |
265 | } | |
266 | if ( $flags =~ /D/ ) { | |
267 | push @attrs, "__attribute__deprecated__"; | |
268 | } | |
269 | if ( $is_malloc ) { | |
270 | push @attrs, "__attribute__malloc__"; | |
271 | } | |
272 | if ( !$can_ignore ) { | |
273 | push @attrs, "__attribute__warn_unused_result__"; | |
274 | } | |
275 | if ( $flags =~ /P/ ) { | |
276 | push @attrs, "__attribute__pure__"; | |
277 | } | |
278 | if ( $flags =~ /I/ ) { | |
279 | push @attrs, "__attribute__always_inline__"; | |
280 | } | |
0351a629 TK |
281 | # roughly the inverse of the rules used in makedef.pl |
282 | if ( $flags !~ /[ACeIimSX]/ ) { | |
283 | push @attrs, '__attribute__visibility__("hidden")' | |
284 | } | |
9824c081 | 285 | if( $flags =~ /f/ ) { |
69e2d40a | 286 | my $prefix = $has_context ? 'pTHX_' : ''; |
c553bad5 | 287 | my ($argc, $pat); |
69e2d40a YO |
288 | if (!defined $args->[1]) { |
289 | use Data::Dumper; | |
290 | die Dumper($_); | |
291 | } | |
292 | if ($args->[-1] eq '...') { | |
293 | $argc = scalar @$args; | |
294 | $pat = $argc - 1; | |
295 | $argc = $prefix . $argc; | |
9824c081 MS |
296 | } |
297 | else { | |
298 | # don't check args, and guess which arg is the pattern | |
299 | # (one of 'fmt', 'pat', 'f'), | |
c553bad5 | 300 | $argc = 0; |
69e2d40a | 301 | my @fmts = grep $args->[$_] =~ /\b(f|pat|fmt)$/, 0..$#$args; |
9824c081 MS |
302 | if (@fmts != 1) { |
303 | die "embed.pl: '$plain_func': can't determine pattern arg\n"; | |
304 | } | |
305 | $pat = $fmts[0] + 1; | |
306 | } | |
69e2d40a | 307 | my $macro = grep($_ == $pat, @nonnull) |
9824c081 MS |
308 | ? '__attribute__format__' |
309 | : '__attribute__format__null_ok__'; | |
310 | if ($plain_func =~ /strftime/) { | |
311 | push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix; | |
312 | } | |
313 | else { | |
314 | push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro, | |
c553bad5 | 315 | $prefix, $pat, $argc; |
9824c081 MS |
316 | } |
317 | } | |
69e2d40a | 318 | elsif ((grep { $_ eq '...' } @$args) && $flags !~ /F/) { |
9824c081 MS |
319 | die_at_end "$plain_func: Function with '...' arguments must have" |
320 | . " f or F flag"; | |
321 | } | |
322 | if ( @attrs ) { | |
323 | $ret .= "\n"; | |
69e2d40a | 324 | $ret .= join( "\n", map { (" " x 8) . $_ } @attrs ); |
9824c081 MS |
325 | } |
326 | $ret .= ";"; | |
327 | $ret = "/* $ret */" if $commented_out; | |
328 | ||
69e2d40a YO |
329 | if ($args_assert_line || @names_of_nn) { |
330 | $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E"; | |
331 | if (@names_of_nn) { | |
332 | $ret .= " \\\n"; | |
333 | my $def = " " x 8; | |
334 | foreach my $ix (0..$#names_of_nn) { | |
335 | $def .= "assert($names_of_nn[$ix])"; | |
336 | if ($ix == $#names_of_nn) { | |
337 | $def .= "\n"; | |
338 | } elsif (length $def > 70) { | |
339 | $ret .= $def . "; \\\n"; | |
340 | $def = " " x 8; | |
341 | } else { | |
342 | $def .= "; "; | |
343 | } | |
344 | } | |
345 | $ret .= $def; | |
346 | } | |
347 | } | |
348 | $ret .= "\n"; | |
349 | ||
350 | $ret = "#${ind}ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#${ind}endif" | |
351 | if $static_inline; | |
352 | $ret = "#${ind}ifndef NO_MATHOMS\n$ret\n#${ind}endif" | |
353 | if $binarycompat; | |
9824c081 | 354 | |
9824c081 MS |
355 | $ret .= @attrs ? "\n\n" : "\n"; |
356 | ||
357 | print $pr $ret; | |
cea2e8a9 | 358 | } |
9516dc40 | 359 | |
9516dc40 | 360 | |
69e2d40a YO |
361 | close $pr; |
362 | ||
363 | my $clean= normalize_group_content($proto_buffer); | |
364 | ||
365 | my $fh = open_print_header("proto.h"); | |
366 | print $fh <<~"EOF"; | |
367 | START_EXTERN_C | |
368 | $clean | |
369 | #ifdef PERL_CORE | |
370 | # include "pp_proto.h" | |
371 | #endif | |
372 | END_EXTERN_C | |
373 | EOF | |
374 | ||
375 | read_only_bottom_close_and_rename($fh) if ! $error_count; | |
376 | } | |
377 | ||
378 | { | |
379 | my $hp= HeaderParser->new(); | |
380 | sub normalize_group_content { | |
381 | open my $in, "<", \$_[0] | |
382 | or die "Failed to open buffer: $!"; | |
383 | $hp->parse_fh($in); | |
384 | my $ppc= sub { | |
385 | my ($self, $line_data)= @_; | |
386 | # re-align defines so that the definitions line up at the 48th col | |
387 | # as much as possible. | |
388 | if ($line_data->{sub_type} eq "#define") { | |
389 | $line_data->{line}=~s/^(\s*#\s*define\s+\S+?(?:\([^()]*\))?\s)(\s*)(\S+)/ | |
390 | sprintf "%-48s%s", $1, $3/e; | |
391 | } | |
392 | }; | |
393 | my $clean= $hp->lines_as_str($hp->group_content(),$ppc); | |
394 | return $clean; | |
395 | } | |
396 | } | |
397 | ||
398 | sub normalize_and_print { | |
399 | my ($file, $buffer)= @_; | |
400 | my $fh = open_print_header($file); | |
401 | print $fh normalize_group_content($buffer); | |
402 | read_only_bottom_close_and_rename($fh); | |
cea2e8a9 GS |
403 | } |
404 | ||
cea2e8a9 | 405 | |
adf34b4b NC |
406 | sub readvars { |
407 | my ($file, $pre) = @_; | |
69e2d40a | 408 | my $hp= HeaderParser->new()->read_file($file); |
adf34b4b | 409 | my %seen; |
69e2d40a YO |
410 | foreach my $line_data (@{$hp->lines}) { |
411 | #next unless $line_data->is_content; | |
412 | my $line= $line_data->line; | |
413 | if ($line=~m/^\s*PERLVARA?I?C?\(\s*$pre\s*,\s*(\w+)/){ | |
414 | $seen{$1}++ | |
415 | and | |
416 | die_at_end "duplicate symbol $1 while processing $file line " | |
417 | . ($line_data->start_line_num) . "\n" | |
9824c081 | 418 | } |
d4cce5f1 | 419 | } |
69e2d40a YO |
420 | my @keys= sort { lc($a) cmp lc($b) || |
421 | $a cmp $b } | |
422 | keys %seen; | |
423 | return @keys; | |
d4cce5f1 NIS |
424 | } |
425 | ||
69e2d40a YO |
426 | sub add_indent { |
427 | #my ($ret, $add, $width)= @_; | |
428 | my $width= $_[2] || 48; | |
429 | $_[0] .= " " x ($width-length($_[0])) if length($_[0])<$width; | |
430 | $_[0] .= " " unless $_[0]=~/\s\z/; | |
431 | if (defined $_[1]) { | |
432 | $_[0] .= $_[1]; | |
433 | } | |
434 | return $_[0]; | |
435 | } | |
d4cce5f1 | 436 | |
69e2d40a YO |
437 | sub indent_define { |
438 | my ($from, $to, $indent, $width) = @_; | |
125218eb | 439 | $indent = '' unless defined $indent; |
69e2d40a YO |
440 | my $ret= "#${indent}define $from"; |
441 | add_indent($ret,"$to\n",$width); | |
5f05dabc | 442 | } |
c6af7a1a | 443 | |
69e2d40a YO |
444 | sub multon { |
445 | my ($sym,$pre,$ptr,$ind) = @_; | |
446 | $ind//=""; | |
447 | indent_define("PL_$sym", "($ptr$pre$sym)", $ind); | |
5f05dabc | 448 | } |
54aff467 | 449 | |
e8a67806 | 450 | sub embed_h { |
69e2d40a | 451 | my ($em, $guard, $funcs) = @_; |
e8a67806 | 452 | |
2a4d8072 | 453 | my $lines; |
e8a67806 | 454 | foreach (@$funcs) { |
69e2d40a YO |
455 | if ($_->{type} ne "content") { |
456 | $lines .= $_->{line}; | |
9824c081 MS |
457 | next; |
458 | } | |
69e2d40a YO |
459 | my $level= $_->{level}; |
460 | my $embed= $_->{embed} or next; | |
461 | my ($flags,$retval,$func,$args) = @{$embed}{qw(flags return_type name args)}; | |
9824c081 | 462 | my $ret = ""; |
69e2d40a YO |
463 | my $ind= $level ? " " : ""; |
464 | $ind .= " " x ($level-1) if $level>1; | |
465 | my $inner_ind= $ind ? " " : " "; | |
9824c081 | 466 | unless ($flags =~ /[omM]/) { |
69e2d40a | 467 | my $argc = scalar @$args; |
9824c081 MS |
468 | if ($flags =~ /T/) { |
469 | my $full_name = full_name($func, $flags); | |
69e2d40a YO |
470 | next if $full_name eq $func; # Don't output a no-op. |
471 | $ret = indent_define($func, $full_name, $ind); | |
9824c081 | 472 | } |
9824c081 | 473 | else { |
69e2d40a | 474 | my $use_va_list = $argc && $args->[-1] =~ /\.\.\./; |
13e5ba49 PE |
475 | |
476 | if($use_va_list) { | |
477 | # CPP has trouble with empty __VA_ARGS__ and comma joining, | |
478 | # so we'll have to eat an extra params here. | |
479 | if($argc < 2) { | |
480 | die "Cannot use ... as the only parameter to a macro ($func)\n"; | |
481 | } | |
482 | $argc -= 2; | |
483 | } | |
484 | ||
485 | my $paramlist = join(",", @az[0..$argc-1], | |
486 | $use_va_list ? ("...") : ()); | |
487 | my $replacelist = join(",", @az[0..$argc-1], | |
488 | $use_va_list ? ("__VA_ARGS__") : ()); | |
69e2d40a YO |
489 | $ret = "#${ind}define $func($paramlist) "; |
490 | add_indent($ret,full_name($func, $flags) . "(aTHX"); | |
13e5ba49 PE |
491 | $ret .= "_ " if $replacelist; |
492 | $ret .= $replacelist; | |
21553840 | 493 | if ($flags =~ /W/) { |
13e5ba49 | 494 | if ($replacelist) { |
21553840 YO |
495 | $ret .= " _aDEPTH"; |
496 | } else { | |
497 | die "Can't use W without other args (currently)"; | |
498 | } | |
499 | } | |
500 | $ret .= ")\n"; | |
13e5ba49 PE |
501 | if($use_va_list) { |
502 | # Make them available to !MULTIPLICITY or PERL_CORE | |
69e2d40a | 503 | $ret = "#${ind}if !defined(MULTIPLICITY) || defined(PERL_CORE)\n" . |
13e5ba49 | 504 | $ret . |
69e2d40a | 505 | "#${ind}endif\n"; |
13e5ba49 | 506 | } |
9824c081 | 507 | } |
69e2d40a | 508 | $ret = "#${ind}ifndef NO_MATHOMS\n$ret#${ind}endif\n" if $flags =~ /b/; |
9824c081 MS |
509 | } |
510 | $lines .= $ret; | |
cea2e8a9 | 511 | } |
69e2d40a YO |
512 | # remove empty blocks |
513 | 1 while $lines =~ s/^#\s*if.*\n#\s*endif.*\n//mg | |
514 | or $lines =~ s/^(#\s*if)\s+(.*)\n#else.*\n/$1 !($2)\n/mg; | |
515 | if ($guard) { | |
516 | print $em "$guard /* guard */\n"; | |
517 | $lines=~s/^#(\s*)/"#".(length($1)?" ":" ").$1/mge; | |
2a4d8072 NC |
518 | } |
519 | print $em $lines; | |
e8a67806 | 520 | print $em "#endif\n" if $guard; |
da4ddda1 NC |
521 | } |
522 | ||
69e2d40a YO |
523 | sub generate_embed_h { |
524 | my ($all, $api, $ext, $core)= @_; | |
e8a67806 | 525 | |
69e2d40a | 526 | my $em= open_buf_out(my $embed_buffer); |
e50aee73 | 527 | |
69e2d40a YO |
528 | print $em <<~'END'; |
529 | /* (Doing namespace management portably in C is really gross.) */ | |
35209cc8 | 530 | |
69e2d40a YO |
531 | /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms |
532 | * (like warn instead of Perl_warn) for the API are not defined. | |
533 | * Not defining the short forms is a good thing for cleaner embedding. | |
534 | * BEWARE that a bunch of macros don't have long names, so either must be | |
535 | * added or don't use them if you define this symbol */ | |
cea2e8a9 | 536 | |
69e2d40a | 537 | #ifndef PERL_NO_SHORT_NAMES |
cea2e8a9 | 538 | |
69e2d40a | 539 | /* Hide global symbols */ |
cea2e8a9 | 540 | |
69e2d40a | 541 | END |
7b53c8ee | 542 | |
69e2d40a YO |
543 | embed_h($em, '', $api); |
544 | embed_h($em, '#if defined(PERL_CORE) || defined(PERL_EXT)', $ext); | |
545 | embed_h($em, '#if defined(PERL_CORE)', $core); | |
7b53c8ee | 546 | |
69e2d40a | 547 | print $em <<~'END'; |
7b53c8ee | 548 | |
69e2d40a YO |
549 | #endif /* #ifndef PERL_NO_SHORT_NAMES */ |
550 | ||
551 | #if !defined(PERL_CORE) | |
552 | /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to | |
553 | * disable them. | |
554 | */ | |
555 | # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) | |
556 | # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) | |
557 | #endif | |
558 | ||
559 | #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) | |
560 | ||
561 | /* Compatibility for various misnamed functions. All functions | |
562 | in the API that begin with "perl_" (not "Perl_") take an explicit | |
563 | interpreter context pointer. | |
564 | The following are not like that, but since they had a "perl_" | |
565 | prefix in previous versions, we provide compatibility macros. | |
566 | */ | |
567 | # define perl_atexit(a,b) call_atexit(a,b) | |
568 | END | |
569 | ||
570 | foreach (@$all) { | |
571 | my $embed= $_->{embed} or next; | |
572 | my ($flags, $retval, $func, $args) = @{$embed}{qw(flags return_type name args)}; | |
573 | next unless $flags =~ /O/; | |
574 | ||
575 | my $alist = join ",", @az[0..$#$args]; | |
576 | my $ret = "# define perl_$func($alist) "; | |
577 | print $em add_indent($ret,"$func($alist)\n"); | |
eacd26c2 NC |
578 | } |
579 | ||
69e2d40a YO |
580 | my @nocontext; |
581 | { | |
582 | my (%has_va, %has_nocontext); | |
583 | foreach (@$all) { | |
584 | my $embed= $_->{embed} | |
585 | or next; | |
586 | ++$has_va{$embed->{name}} if @{$embed->{args}} and $embed->{args}[-1] =~ /\.\.\./; | |
587 | ++$has_nocontext{$1} if $embed->{name} =~ /(.*)_nocontext/; | |
588 | } | |
eacd26c2 | 589 | |
69e2d40a YO |
590 | @nocontext = sort grep { |
591 | $has_nocontext{$_} | |
592 | && !/printf/ # Not clear to me why these are skipped but they are. | |
593 | } keys %has_va; | |
594 | } | |
cea2e8a9 | 595 | |
69e2d40a | 596 | print $em <<~'END'; |
125218eb | 597 | |
69e2d40a YO |
598 | /* varargs functions can't be handled with CPP macros. :-( |
599 | This provides a set of compatibility functions that don't take | |
600 | an extra argument but grab the context pointer using the macro | |
601 | dTHX. | |
602 | */ | |
603 | #if defined(MULTIPLICITY) && !defined(PERL_NO_SHORT_NAMES) | |
604 | END | |
125218eb | 605 | |
69e2d40a YO |
606 | foreach (@nocontext) { |
607 | print $em indent_define($_, "Perl_${_}_nocontext", " "); | |
608 | } | |
609 | ||
610 | print $em <<~'END'; | |
611 | #endif | |
cea2e8a9 | 612 | |
69e2d40a | 613 | #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ |
cea2e8a9 | 614 | |
69e2d40a YO |
615 | #if !defined(MULTIPLICITY) |
616 | /* undefined symbols, point them back at the usual ones */ | |
617 | END | |
618 | ||
619 | foreach (@nocontext) { | |
620 | print $em indent_define("Perl_${_}_nocontext", "Perl_$_", " "); | |
621 | } | |
125218eb | 622 | |
69e2d40a YO |
623 | print $em "#endif\n"; |
624 | close $em; | |
625 | ||
626 | normalize_and_print('embed.h',$embed_buffer) | |
627 | unless $error_count; | |
125218eb NC |
628 | } |
629 | ||
69e2d40a YO |
630 | sub generate_embedvar_h { |
631 | my $em = open_buf_out(my $embedvar_buffer); | |
d4cce5f1 | 632 | |
69e2d40a YO |
633 | print $em "#if defined(MULTIPLICITY)\n", |
634 | indent_define("vTHX","aTHX"," "); | |
d4cce5f1 | 635 | |
d4cce5f1 | 636 | |
69e2d40a YO |
637 | my @intrp = readvars 'intrpvar.h','I'; |
638 | #my @globvar = readvars 'perlvars.h','G'; | |
e50aee73 | 639 | |
adf34b4b | 640 | |
69e2d40a YO |
641 | for my $sym (@intrp) { |
642 | my $ind = " "; | |
643 | if ($sym eq 'sawampersand') { | |
644 | print $em "# if !defined(PL_sawampersand)\n"; | |
645 | $ind = " "; | |
646 | } | |
647 | my $line = multon($sym, 'I', 'vTHX->', $ind); | |
648 | print $em $line; | |
649 | if ($sym eq 'sawampersand') { | |
650 | print $em "# endif /* !defined(PL_sawampersand) */\n"; | |
651 | } | |
1a904fc8 | 652 | } |
d4cce5f1 | 653 | |
69e2d40a YO |
654 | print $em "#endif /* MULTIPLICITY */\n"; |
655 | close $em; | |
d4cce5f1 | 656 | |
69e2d40a YO |
657 | normalize_and_print('embedvar.h',$embedvar_buffer) |
658 | unless $error_count; | |
659 | } | |
84fee439 | 660 | |
69e2d40a YO |
661 | sub update_headers { |
662 | my ($all, $api, $ext, $core) = setup_embed(); # see regen/embed_lib.pl | |
663 | generate_proto_h($all); | |
664 | die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; | |
665 | generate_embed_h($all, $api, $ext, $core); | |
666 | generate_embedvar_h(); | |
667 | die "$error_count errors found" if $error_count; | |
668 | } | |
c6af7a1a | 669 | |
69e2d40a | 670 | update_headers() unless caller; |
acfe0abc | 671 | |
1b6737cc | 672 | # ex: set ts=8 sts=4 sw=4 noet: |