This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
l1_char_class_tab.h: Remove multi-char fold targets
[perl5.git] / regen / embed.pl
CommitLineData
5f05dabc 1#!/usr/bin/perl -w
6294c161
DM
2#
3# Regenerate (overwriting only if changed):
4#
5# embed.h
6# embedvar.h
7# global.sym
8# perlapi.c
9# perlapi.h
10# proto.h
11#
12# from information stored in
13#
14# embed.fnc
15# intrpvar.h
16# perlvars.h
897d3989 17# regen/opcodes
6294c161 18#
6294c161
DM
19# Accepts the standard regen_lib -q and -v args.
20#
21# This script is normally invoked from regen.pl.
e50aee73 22
916e4025 23require 5.004; # keep this compatible, an old perl is all we may have before
954c1994 24 # we build the new one
5f05dabc 25
88e01c9d
AL
26use strict;
27
36bb303b
NC
28BEGIN {
29 # Get function prototypes
af001346 30 require 'regen/regen_lib.pl';
36bb303b
NC
31}
32
88e01c9d 33my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
916e4025 34my $unflagged_pointers;
88e01c9d 35
cea2e8a9 36#
346f75ff 37# See database of global and static function prototypes in embed.fnc
cea2e8a9
GS
38# This is used to generate prototype headers under various configurations,
39# export symbols lists for different platforms, and macros to provide an
40# implicit interpreter context argument.
41#
42
7f1be197
MB
43sub do_not_edit ($)
44{
45 my $file = shift;
4373e329 46
78102347
NC
47 return read_only_top(lang => ($file =~ /\.[ch]$/ ? 'C' : 'Perl'),
48 file => $file, style => '*', by => 'regen/embed.pl',
49 from => ['data in embed.fnc', 'regen/embed.pl',
50 'regen/opcodes', 'intrpvar.h', 'perlvars.h'],
51 final => "\nEdit those files and run 'make regen_headers' to effect changes.\n",
52 copyright => [1993 .. 2009]);
7f1be197
MB
53} # do_not_edit
54
94bdecf9 55open IN, "embed.fnc" or die $!;
cea2e8a9 56
881a2100 57my @embed;
125218eb 58my (%has_va, %has_nocontext);
881a2100
NC
59
60while (<IN>) {
61 chomp;
62 next if /^:/;
24dd05fb 63 next if /^$/;
881a2100
NC
64 while (s|\\$||) {
65 $_ .= <IN>;
66 chomp;
67 }
68 s/\s+$//;
69 my @args;
70 if (/^\s*(#|$)/) {
71 @args = $_;
72 }
73 else {
74 @args = split /\s*\|\s*/, $_;
125218eb
NC
75 my $func = $args[2];
76 if ($func) {
77 ++$has_va{$func} if $args[-1] =~ /\.\.\./;
78 ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
79 }
881a2100 80 }
7c662e8a
NC
81 if (@args == 1 && $args[0] !~ /^#\s*(?:if|ifdef|ifndef|else|endif)/) {
82 die "Illegal line $. '$args[0]' in embed.fnc";
83 }
881a2100
NC
84 push @embed, \@args;
85}
86
146326cb
NC
87open IN, 'regen/opcodes' or die $!;
88{
89 my %syms;
90
91 while (<IN>) {
92 chop;
93 next unless $_;
94 next if /^#/;
95 my (undef, undef, $check) = split /\t+/, $_;
96 ++$syms{$check};
97 }
98
99 foreach (keys %syms) {
100 # These are all indirectly referenced by globals.c.
101 push @embed, ['pR', 'OP *', $_, 'NN OP *o'];
102 }
103}
104close IN;
105
e8a67806 106my (@core, @ext, @api);
c527bc84 107{
e8a67806
NC
108 # Cluster entries in embed.fnc that have the same #ifdef guards.
109 # Also, split out at the top level the three classes of functions.
110 my @state;
111 my %groups;
112 my $current;
c527bc84 113 foreach (@embed) {
e8a67806
NC
114 if (@$_ > 1) {
115 push @$current, $_;
116 next;
117 }
c527bc84
NC
118 $_->[0] =~ s/^#\s+/#/;
119 $_->[0] =~ /^\S*/;
120 $_->[0] =~ s/^#ifdef\s+(\S+)/#if defined($1)/;
121 $_->[0] =~ s/^#ifndef\s+(\S+)/#if !defined($1)/;
e8a67806
NC
122 if ($_->[0] =~ /^#if\s*(.*)/) {
123 push @state, $1;
124 } elsif ($_->[0] =~ /^#else\s*$/) {
125 die "Unmatched #else in embed.fnc" unless @state;
126 $state[-1] = "!($state[-1])";
127 } elsif ($_->[0] =~ m!^#endif\s*(?:/\*.*\*/)?$!) {
128 die "Unmatched #endif in embed.fnc" unless @state;
129 pop @state;
130 } else {
131 die "Unhandled pre-processor directive '$_->[0]' in embed.fnc";
132 }
133 $current = \%groups;
134 # Nested #if blocks are effectively &&ed together
135 # For embed.fnc, ordering withing the && isn't relevant, so we can
136 # sort them to try to group more functions together.
137 my @sorted = sort @state;
138 while (my $directive = shift @sorted) {
139 $current->{$directive} ||= {};
140 $current = $current->{$directive};
141 }
142 $current->{''} ||= [];
143 $current = $current->{''};
144 }
145
146 sub add_level {
147 my ($level, $indent, $wanted) = @_;
148 my $funcs = $level->{''};
149 my @entries;
150 if ($funcs) {
151 if (!defined $wanted) {
152 @entries = @$funcs;
153 } else {
154 foreach (@$funcs) {
155 if ($_->[0] =~ /A/) {
156 push @entries, $_ if $wanted eq 'A';
157 } elsif ($_->[0] =~ /E/) {
158 push @entries, $_ if $wanted eq 'E';
159 } else {
160 push @entries, $_ if $wanted eq '';
161 }
162 }
163 }
164 @entries = sort {$a->[2] cmp $b->[2]} @entries;
165 }
166 foreach (sort grep {length $_} keys %$level) {
167 my @conditional = add_level($level->{$_}, $indent . ' ', $wanted);
168 push @entries,
169 ["#${indent}if $_"], @conditional, ["#${indent}endif"]
170 if @conditional;
171 }
172 return @entries;
c527bc84 173 }
e8a67806
NC
174 @core = add_level(\%groups, '', '');
175 @ext = add_level(\%groups, '', 'E');
176 @api = add_level(\%groups, '', 'A');
177
178 @embed = add_level(\%groups, '');
c527bc84
NC
179}
180
cea2e8a9
GS
181# walk table providing an array of components in each line to
182# subroutine, printing the result
183sub walk_table (&@) {
ce716c52 184 my ($function, $filename) = @_;
cea2e8a9 185 my $F;
cea2e8a9
GS
186 if (ref $filename) { # filehandle
187 $F = $filename;
188 }
d0ee0d3d 189 else {
f038801a 190 $F = safer_open("$filename-new", $filename);
1028dc3c 191 print $F do_not_edit ($filename);
cea2e8a9 192 }
881a2100
NC
193 foreach (@embed) {
194 my @outs = &{$function}(@$_);
1028dc3c 195 # $function->(@args) is not 5.003
d0ee0d3d 196 print $F @outs;
cea2e8a9 197 }
d0ee0d3d 198 unless (ref $filename) {
ce716c52 199 read_only_bottom_close_and_rename($F);
36bb303b 200 }
cea2e8a9
GS
201}
202
cea2e8a9 203# generate proto.h
9516dc40 204{
f038801a 205 my $pr = safer_open('proto.h-new', 'proto.h');
78102347 206 print $pr do_not_edit ("proto.h"), "START_EXTERN_C\n";
f8394530 207 my $ret;
9516dc40
NC
208
209 foreach (@embed) {
210 if (@$_ == 1) {
211 print $pr "$_->[0]\n";
212 next;
213 }
214
215 my ($flags,$retval,$plain_func,@args) = @$_;
4373e329
AL
216 my @nonnull;
217 my $has_context = ( $flags !~ /n/ );
88e01c9d
AL
218 my $never_returns = ( $flags =~ /r/ );
219 my $commented_out = ( $flags =~ /m/ );
aa4ca557 220 my $binarycompat = ( $flags =~ /b/ );
88e01c9d
AL
221 my $is_malloc = ( $flags =~ /a/ );
222 my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
7918f24d
NC
223 my @names_of_nn;
224 my $func;
88e01c9d
AL
225
226 my $splint_flags = "";
227 if ( $SPLINT && !$commented_out ) {
228 $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
229 if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
230 $retval .= " /*\@alt void\@*/";
231 }
232 }
233
71556506
KW
234 if ($flags =~ /([si])/) {
235 my $type = ($1 eq 's') ? "STATIC" : "PERL_STATIC_INLINE";
236 warn "$func: i and s flags are mutually exclusive"
237 if $flags =~ /s/ && $flags =~ /i/;
238 $retval = "$type $splint_flags$retval";
7918f24d 239 $func = "S_$plain_func";
cea2e8a9 240 }
0cb96387 241 else {
88e01c9d 242 $retval = "PERL_CALLCONV $splint_flags$retval";
25b0f989 243 if ($flags =~ /[bp]/) {
7918f24d
NC
244 $func = "Perl_$plain_func";
245 } else {
246 $func = $plain_func;
0cb96387 247 }
cea2e8a9 248 }
f8394530 249 $ret = "$retval\t$func(";
4373e329
AL
250 if ( $has_context ) {
251 $ret .= @args ? "pTHX_ " : "pTHX";
cea2e8a9
GS
252 }
253 if (@args) {
4373e329
AL
254 my $n;
255 for my $arg ( @args ) {
256 ++$n;
7827dc65
AL
257 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
258 warn "$func: $arg needs NN or NULLOK\n";
7827dc65
AL
259 ++$unflagged_pointers;
260 }
88e01c9d
AL
261 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
262 push( @nonnull, $n ) if $nn;
263
264 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
c48640ec
AL
265
266 # Make sure each arg has at least a type and a var name.
267 # An arg of "int" is valid C, but want it to be "int foo".
268 my $temp_arg = $arg;
269 $temp_arg =~ s/\*//g;
270 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
7918f24d
NC
271 if ( ($temp_arg ne "...")
272 && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
273 warn "$func: $arg ($n) doesn't have a name\n";
c48640ec 274 }
88e01c9d
AL
275 if ( $SPLINT && $nullok && !$commented_out ) {
276 $arg = '/*@null@*/ ' . $arg;
277 }
aa4ca557 278 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
7918f24d
NC
279 push @names_of_nn, $1;
280 }
4373e329 281 }
cea2e8a9
GS
282 $ret .= join ", ", @args;
283 }
284 else {
4373e329 285 $ret .= "void" if !$has_context;
cea2e8a9
GS
286 }
287 $ret .= ")";
f54cb97a
AL
288 my @attrs;
289 if ( $flags =~ /r/ ) {
abb2c242 290 push @attrs, "__attribute__noreturn__";
f54cb97a 291 }
a5c26493
RGS
292 if ( $flags =~ /D/ ) {
293 push @attrs, "__attribute__deprecated__";
294 }
88e01c9d 295 if ( $is_malloc ) {
abb2c242 296 push @attrs, "__attribute__malloc__";
f54cb97a 297 }
88e01c9d 298 if ( !$can_ignore ) {
abb2c242 299 push @attrs, "__attribute__warn_unused_result__";
f54cb97a
AL
300 }
301 if ( $flags =~ /P/ ) {
abb2c242 302 push @attrs, "__attribute__pure__";
f54cb97a 303 }
1c846c1f 304 if( $flags =~ /f/ ) {
cdfeb707
RB
305 my $prefix = $has_context ? 'pTHX_' : '';
306 my $args = scalar @args;
307 my $pat = $args - 1;
308 my $macro = @nonnull && $nonnull[-1] == $pat
309 ? '__attribute__format__'
310 : '__attribute__format__null_ok__';
311 push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
312 $prefix, $pat, $prefix, $args;
894356b3 313 }
4373e329 314 if ( @nonnull ) {
3d42dc86 315 my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
abb2c242 316 push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
f54cb97a
AL
317 }
318 if ( @attrs ) {
319 $ret .= "\n";
320 $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
4373e329 321 }
af3c7592 322 $ret .= ";";
88e01c9d 323 $ret = "/* $ret */" if $commented_out;
7918f24d
NC
324 if (@names_of_nn) {
325 $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
326 . join '; ', map "assert($_)", @names_of_nn;
327 }
f54cb97a 328 $ret .= @attrs ? "\n\n" : "\n";
9516dc40
NC
329
330 print $pr $ret;
cea2e8a9 331 }
9516dc40 332
897d3989
NC
333 print $pr <<'EOF';
334#ifdef PERL_CORE
335# include "pp_proto.h"
336#endif
337END_EXTERN_C
897d3989 338EOF
9516dc40 339
ce716c52 340 read_only_bottom_close_and_rename($pr);
cea2e8a9
GS
341}
342
2b10efc6
NC
343# generates global.sym (API export list)
344{
345 my %seen;
346 sub write_global_sym {
2b10efc6
NC
347 if (@_ > 1) {
348 my ($flags,$retval,$func,@args) = @_;
2b10efc6
NC
349 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
350 || $flags =~ /b/) { # public API, so export
9be14afe
NC
351 # If a function is defined twice, for example before and after
352 # an #else, only export its name once.
353 return '' if $seen{$func}++;
2b10efc6 354 $func = "Perl_$func" if $flags =~ /[pbX]/;
f8394530 355 return "$func\n";
2b10efc6
NC
356 }
357 }
f8394530 358 return '';
2b10efc6 359 }
cea2e8a9
GS
360}
361
7827dc65 362warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
ce716c52 363walk_table(\&write_global_sym, "global.sym");
cea2e8a9 364
c6af7a1a
GS
365sub readvars(\%$$@) {
366 my ($syms, $file,$pre,$keep_pre) = @_;
d4cce5f1
NIS
367 local (*FILE, $_);
368 open(FILE, "< $file")
369 or die "embed.pl: Can't open $file: $!\n";
370 while (<FILE>) {
371 s/[ \t]*#.*//; # Delete comments.
27da23d5 372 if (/PERLVARA?I?S?C?\($pre(\w+)/) {
22c35a8c 373 my $sym = $1;
c6af7a1a 374 $sym = $pre . $sym if $keep_pre;
d1594dd0 375 warn "duplicate symbol $sym while processing $file line $.\n"
22c35a8c 376 if exists $$syms{$sym};
51371543 377 $$syms{$sym} = $pre || 1;
d4cce5f1
NIS
378 }
379 }
380 close(FILE);
381}
382
383my %intrp;
88e01c9d 384my %globvar;
d4cce5f1
NIS
385
386readvars %intrp, 'intrpvar.h','I';
22239a37 387readvars %globvar, 'perlvars.h','G';
d4cce5f1 388
4543f4c0 389my $sym;
d4cce5f1 390
c6af7a1a
GS
391sub undefine ($) {
392 my ($sym) = @_;
393 "#undef $sym\n";
394}
395
125218eb
NC
396sub hide {
397 my ($from, $to, $indent) = @_;
398 $indent = '' unless defined $indent;
399 my $t = int(length("$indent$from") / 8);
400 "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
5f05dabc 401}
c6af7a1a 402
6f4183fe 403sub bincompat_var ($$) {
51371543 404 my ($pfx, $sym) = @_;
acfe0abc 405 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
c5be433b 406 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
c6af7a1a
GS
407}
408
d4cce5f1
NIS
409sub multon ($$$) {
410 my ($sym,$pre,$ptr) = @_;
3280af22 411 hide("PL_$sym", "($ptr$pre$sym)");
5f05dabc 412}
54aff467 413
d4cce5f1
NIS
414sub multoff ($$) {
415 my ($sym,$pre) = @_;
533c011a 416 return hide("PL_$pre$sym", "PL_$sym");
5f05dabc
PP
417}
418
f038801a 419my $em = safer_open('embed.h-new', 'embed.h');
e50aee73 420
424a4936 421print $em do_not_edit ("embed.h"), <<'END';
e50aee73
AD
422/* (Doing namespace management portably in C is really gross.) */
423
d51482e4
JH
424/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
425 * (like warn instead of Perl_warn) for the API are not defined.
426 * Not defining the short forms is a good thing for cleaner embedding. */
427
428#ifndef PERL_NO_SHORT_NAMES
820c3be9 429
22c35a8c 430/* Hide global symbols */
5f05dabc 431
e50aee73
AD
432END
433
cea2e8a9
GS
434my @az = ('a'..'z');
435
e8a67806
NC
436sub embed_h {
437 my ($guard, $funcs) = @_;
438 print $em "$guard\n" if $guard;
439
2a4d8072 440 my $lines;
e8a67806
NC
441 foreach (@$funcs) {
442 if (@$_ == 1) {
443 my $cond = $_->[0];
444 # Indent the conditionals if we are wrapped in an #if/#endif pair.
445 $cond =~ s/#(.*)/# $1/ if $guard;
2a4d8072 446 $lines .= "$cond\n";
e8a67806
NC
447 next;
448 }
449 my $ret = "";
450 my ($flags,$retval,$func,@args) = @$_;
af3c7592 451 unless ($flags =~ /[om]/) {
cea2e8a9 452 my $args = scalar @args;
7a5a24f7 453 if ($flags =~ /n/) {
cea2e8a9 454 if ($flags =~ /s/) {
f8394530 455 $ret = hide($func,"S_$func");
cea2e8a9
GS
456 }
457 elsif ($flags =~ /p/) {
f8394530 458 $ret = hide($func,"Perl_$func");
cea2e8a9
GS
459 }
460 }
7a5a24f7 461 elsif ($args and $args[$args-1] =~ /\.\.\./) {
e64ca59f
NC
462 if ($flags =~ /p/) {
463 # we're out of luck for varargs functions under CPP
464 # So we can only do these macros for no implicit context:
465 $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
466 . hide($func,"Perl_$func") . "#endif\n";
467 }
7a5a24f7 468 }
cea2e8a9
GS
469 else {
470 my $alist = join(",", @az[0..$args-1]);
471 $ret = "#define $func($alist)";
472 my $t = int(length($ret) / 8);
473 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
71556506 474 if ($flags =~ /[si]/) {
cea2e8a9
GS
475 $ret .= "S_$func(aTHX";
476 }
477 elsif ($flags =~ /p/) {
478 $ret .= "Perl_$func(aTHX";
479 }
480 $ret .= "_ " if $alist;
481 $ret .= $alist . ")\n";
482 }
483 }
2a4d8072 484 $lines .= $ret;
cea2e8a9 485 }
2a4d8072
NC
486 # Prune empty #if/#endif pairs.
487 while ($lines =~ s/#\s*if[^\n]+\n#\s*endif\n//) {
488 }
b2e549c0
NC
489 # Merge adjacent blocks.
490 while ($lines =~ s/(#ifndef PERL_IMPLICIT_CONTEXT
491[^\n]+
492)#endif
493#ifndef PERL_IMPLICIT_CONTEXT
494/$1/) {
495 }
496
2a4d8072 497 print $em $lines;
e8a67806 498 print $em "#endif\n" if $guard;
da4ddda1
NC
499}
500
e8a67806
NC
501embed_h('', \@api);
502embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', \@ext);
503embed_h('#ifdef PERL_CORE', \@core);
504
424a4936 505print $em <<'END';
e50aee73 506
d51482e4 507#endif /* #ifndef PERL_NO_SHORT_NAMES */
35209cc8 508
cea2e8a9
GS
509/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
510 disable them.
511 */
512
538feb02 513#if !defined(PERL_CORE)
5bc28da9 514# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
a0714e2c 515# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
538feb02 516#endif
cea2e8a9 517
08e5223a 518#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
cea2e8a9
GS
519
520/* Compatibility for various misnamed functions. All functions
521 in the API that begin with "perl_" (not "Perl_") take an explicit
522 interpreter context pointer.
523 The following are not like that, but since they had a "perl_"
524 prefix in previous versions, we provide compatibility macros.
525 */
65cec589 526# define perl_atexit(a,b) call_atexit(a,b)
7b53c8ee
NC
527END
528
529walk_table {
530 my ($flags,$retval,$func,@args) = @_;
531 return unless $func;
532 return unless $flags =~ /O/;
533
534 my $alist = join ",", @az[0..$#args];
535 my $ret = "# define perl_$func($alist)";
536 my $t = (length $ret) >> 3;
537 $ret .= "\t" x ($t < 5 ? 5 - $t : 1);
538 "$ret$func($alist)\n";
1028dc3c 539} $em;
7b53c8ee
NC
540
541print $em <<'END';
cea2e8a9
GS
542
543/* varargs functions can't be handled with CPP macros. :-(
544 This provides a set of compatibility functions that don't take
545 an extra argument but grab the context pointer using the macro
546 dTHX.
547 */
d51482e4 548#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
125218eb
NC
549END
550
551foreach (sort keys %has_va) {
552 next unless $has_nocontext{$_};
553 next if /printf/; # Not clear to me why these are skipped but they are.
554 print $em hide($_, "Perl_${_}_nocontext", " ");
555}
556
557print $em <<'END';
cea2e8a9
GS
558#endif
559
560#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
561
562#if !defined(PERL_IMPLICIT_CONTEXT)
563/* undefined symbols, point them back at the usual ones */
125218eb
NC
564END
565
566foreach (sort keys %has_va) {
567 next unless $has_nocontext{$_};
568 next if /printf/; # Not clear to me why these are skipped but they are.
569 print $em hide("Perl_${_}_nocontext", "Perl_$_", " ");
570}
571
572print $em <<'END';
cea2e8a9 573#endif
d4cce5f1
NIS
574END
575
ce716c52 576read_only_bottom_close_and_rename($em);
d4cce5f1 577
f038801a 578$em = safer_open('embedvar.h-new', 'embedvar.h');
d4cce5f1 579
424a4936 580print $em do_not_edit ("embedvar.h"), <<'END';
d4cce5f1
NIS
581/* (Doing namespace management portably in C is really gross.) */
582
54aff467 583/*
3db8f154
MB
584 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
585 are supported:
54aff467
GS
586 1) none
587 2) MULTIPLICITY # supported for compatibility
588 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
54aff467
GS
589
590 All other combinations of these flags are errors.
591
3db8f154 592 only #3 is supported directly, while #2 is a special
54aff467
GS
593 case of #3 (supported by redefining vTHX appropriately).
594*/
cea2e8a9 595
54aff467 596#if defined(MULTIPLICITY)
3db8f154 597/* cases 2 and 3 above */
cea2e8a9 598
54aff467
GS
599# if defined(PERL_IMPLICIT_CONTEXT)
600# define vTHX aTHX
601# else
602# define vTHX PERL_GET_INTERP
603# endif
cea2e8a9 604
e50aee73
AD
605END
606
d4cce5f1 607for $sym (sort keys %intrp) {
424a4936 608 print $em multon($sym,'I','vTHX->');
d4cce5f1
NIS
609}
610
424a4936 611print $em <<'END';
d4cce5f1 612
54aff467 613#else /* !MULTIPLICITY */
1d7c1841 614
3db8f154 615/* case 1 above */
5f05dabc 616
56d28764 617END
e50aee73 618
d4cce5f1 619for $sym (sort keys %intrp) {
424a4936 620 print $em multoff($sym,'I');
d4cce5f1
NIS
621}
622
424a4936 623print $em <<'END';
d4cce5f1 624
d4cce5f1
NIS
625END
626
424a4936 627print $em <<'END';
d4cce5f1 628
54aff467 629#endif /* MULTIPLICITY */
d4cce5f1 630
54aff467 631#if defined(PERL_GLOBAL_STRUCT)
22239a37
NIS
632
633END
634
635for $sym (sort keys %globvar) {
424a4936
NC
636 print $em multon($sym, 'G','my_vars->');
637 print $em multon("G$sym",'', 'my_vars->');
22239a37
NIS
638}
639
424a4936 640print $em <<'END';
22239a37
NIS
641
642#else /* !PERL_GLOBAL_STRUCT */
643
644END
645
646for $sym (sort keys %globvar) {
424a4936 647 print $em multoff($sym,'G');
22239a37
NIS
648}
649
424a4936 650print $em <<'END';
22239a37 651
22239a37 652#endif /* PERL_GLOBAL_STRUCT */
84fee439
NIS
653END
654
ce716c52 655read_only_bottom_close_and_rename($em);
c6af7a1a 656
f038801a
NC
657my $capi = safer_open('perlapi.c-new', 'perlapi.c');
658my $capih = safer_open('perlapi.h-new', 'perlapi.h');
51371543 659
424a4936 660print $capih do_not_edit ("perlapi.h"), <<'EOT';
51371543 661/* declare accessor functions for Perl variables */
6f4183fe
GS
662#ifndef __perlapi_h__
663#define __perlapi_h__
51371543 664
87b9e160 665#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
c5be433b 666
51371543
GS
667START_EXTERN_C
668
669#undef PERLVAR
670#undef PERLVARA
671#undef PERLVARI
672#undef PERLVARIC
27da23d5 673#undef PERLVARISC
acfe0abc 674#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
51371543 675#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
acfe0abc 676 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
51371543 677#define PERLVARI(v,t,i) PERLVAR(v,t)
c5be433b 678#define PERLVARIC(v,t,i) PERLVAR(v, const t)
27da23d5
JH
679#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
680 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
51371543 681
51371543
GS
682#include "perlvars.h"
683
684#undef PERLVAR
685#undef PERLVARA
686#undef PERLVARI
687#undef PERLVARIC
27da23d5
JH
688#undef PERLVARISC
689
51371543
GS
690END_EXTERN_C
691
682fc664 692#if defined(PERL_CORE)
6f4183fe 693
87b9e160 694/* accessor functions for Perl "global" variables */
682fc664
GS
695
696/* these need to be mentioned here, or most linkers won't put them in
697 the perl executable */
698
699#ifndef PERL_NO_FORCE_LINK
700
701START_EXTERN_C
702
703#ifndef DOINIT
27da23d5 704EXTCONST void * const PL_force_link_funcs[];
682fc664 705#else
27da23d5 706EXTCONST void * const PL_force_link_funcs[] = {
682fc664
GS
707#undef PERLVAR
708#undef PERLVARA
709#undef PERLVARI
710#undef PERLVARIC
ea1f607c 711#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
682fc664
GS
712#define PERLVARA(v,n,t) PERLVAR(v,t)
713#define PERLVARI(v,t,i) PERLVAR(v,t)
714#define PERLVARIC(v,t,i) PERLVAR(v,t)
27da23d5 715#define PERLVARISC(v,i) PERLVAR(v,char)
682fc664 716
3c0f78ca
JH
717/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
718 * cannot cast between void pointers and function pointers without
719 * info level warnings. The PL_force_link_funcs[] would cause a few
720 * hundred of those warnings. In code one can circumnavigate this by using
721 * unions that overlay the different pointers, but in declarations one
722 * cannot use this trick. Therefore we just disable the warning here
723 * for the duration of the PL_force_link_funcs[] declaration. */
724
725#if defined(__DECC) && defined(__osf__)
726#pragma message save
727#pragma message disable (nonstandcast)
728#endif
729
682fc664
GS
730#include "perlvars.h"
731
3c0f78ca
JH
732#if defined(__DECC) && defined(__osf__)
733#pragma message restore
734#endif
735
682fc664
GS
736#undef PERLVAR
737#undef PERLVARA
738#undef PERLVARI
739#undef PERLVARIC
27da23d5 740#undef PERLVARISC
682fc664
GS
741};
742#endif /* DOINIT */
743
acfe0abc 744END_EXTERN_C
682fc664
GS
745
746#endif /* PERL_NO_FORCE_LINK */
747
748#else /* !PERL_CORE */
51371543
GS
749
750EOT
751
4543f4c0 752foreach $sym (sort keys %globvar) {
424a4936 753 print $capih bincompat_var('G',$sym);
6f4183fe
GS
754}
755
424a4936 756print $capih <<'EOT';
6f4183fe
GS
757
758#endif /* !PERL_CORE */
87b9e160 759#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
6f4183fe
GS
760
761#endif /* __perlapi_h__ */
6f4183fe 762EOT
ce716c52
NC
763
764read_only_bottom_close_and_rename($capih);
51371543 765
892eaa71
NC
766my $warning = do_not_edit ("perlapi.c");
767$warning =~ s! \*/\n! *
768 *
769 * Up to the threshold of the door there mounted a flight of twenty-seven
770 * broad stairs, hewn by some unknown art of the same black stone. This
771 * was the only entrance to the tower; ...
772 *
773 * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
774 *
775 */
776!;
777
778print $capi $warning, <<'EOT';
51371543
GS
779#include "EXTERN.h"
780#include "perl.h"
781#include "perlapi.h"
782
87b9e160 783#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
51371543 784
87b9e160 785/* accessor functions for Perl "global" variables */
51371543
GS
786START_EXTERN_C
787
51371543 788#undef PERLVARI
87b9e160 789#define PERLVARI(v,t,i) PERLVAR(v,t)
c5be433b
GS
790
791#undef PERLVAR
792#undef PERLVARA
acfe0abc 793#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
96a5add6 794 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
acfe0abc 795#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
96a5add6 796 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
34f7a5fe 797#undef PERLVARIC
27da23d5
JH
798#undef PERLVARISC
799#define PERLVARIC(v,t,i) \
800 const t* Perl_##v##_ptr(pTHX) \
96a5add6 801 { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
27da23d5 802#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
96a5add6 803 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
51371543
GS
804#include "perlvars.h"
805
806#undef PERLVAR
807#undef PERLVARA
808#undef PERLVARI
809#undef PERLVARIC
27da23d5
JH
810#undef PERLVARISC
811
acfe0abc 812END_EXTERN_C
6f4183fe 813
87b9e160 814#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
51371543
GS
815EOT
816
ce716c52 817read_only_bottom_close_and_rename($capi);
acfe0abc 818
1b6737cc 819# ex: set ts=8 sts=4 sw=4 noet: