This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In embed.pl's walk_table, the default filename of '-' was never used.
[perl5.git] / 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
17# pp.sym (which has been generated by opcode.pl)
18#
19# plus from the values hardcoded into this script in @extvars.
20#
21# Accepts the standard regen_lib -q and -v args.
22#
23# This script is normally invoked from regen.pl.
e50aee73 24
954c1994
GS
25require 5.003; # keep this compatible, an old perl is all we may have before
26 # we build the new one
5f05dabc 27
88e01c9d
AL
28use strict;
29
36bb303b
NC
30BEGIN {
31 # Get function prototypes
9ad884cb 32 require 'regen_lib.pl';
36bb303b
NC
33}
34
88e01c9d
AL
35my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
36
cea2e8a9 37#
346f75ff 38# See database of global and static function prototypes in embed.fnc
cea2e8a9
GS
39# This is used to generate prototype headers under various configurations,
40# export symbols lists for different platforms, and macros to provide an
41# implicit interpreter context argument.
42#
43
7f1be197
MB
44sub do_not_edit ($)
45{
46 my $file = shift;
4373e329 47
83706693 48 my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
4bb101f2
JH
49
50 $years =~ s/1999,/1999,\n / if length $years > 40;
51
7f1be197 52 my $warning = <<EOW;
37442d52 53 -*- buffer-read-only: t -*-
7f1be197
MB
54
55 $file
56
4bb101f2 57 Copyright (C) $years, by Larry Wall and others
7f1be197
MB
58
59 You may distribute under the terms of either the GNU General Public
60 License or the Artistic License, as specified in the README file.
61
62!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
63This file is built by embed.pl from data in embed.fnc, embed.pl,
907b3e23 64pp.sym, intrpvar.h, and perlvars.h.
7f1be197
MB
65Any changes made here will be lost!
66
67Edit those files and run 'make regen_headers' to effect changes.
68
69EOW
70
cfa0b873
AT
71 $warning .= <<EOW if $file eq 'perlapi.c';
72
73Up to the threshold of the door there mounted a flight of twenty-seven
74broad stairs, hewn by some unknown art of the same black stone. This
4ac71550
TC
75was the only entrance to the tower; ...
76
77 [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
cfa0b873
AT
78
79
80EOW
81
7f1be197 82 if ($file =~ m:\.[ch]$:) {
0ea9712b
MB
83 $warning =~ s:^: * :gm;
84 $warning =~ s: +$::gm;
85 $warning =~ s: :/:;
86 $warning =~ s:$:/:;
7f1be197
MB
87 }
88 else {
0ea9712b
MB
89 $warning =~ s:^:# :gm;
90 $warning =~ s: +$::gm;
7f1be197
MB
91 }
92 $warning;
93} # do_not_edit
94
94bdecf9 95open IN, "embed.fnc" or die $!;
cea2e8a9 96
881a2100 97my @embed;
125218eb 98my (%has_va, %has_nocontext);
881a2100
NC
99
100while (<IN>) {
101 chomp;
102 next if /^:/;
103 while (s|\\$||) {
104 $_ .= <IN>;
105 chomp;
106 }
107 s/\s+$//;
108 my @args;
109 if (/^\s*(#|$)/) {
110 @args = $_;
111 }
112 else {
113 @args = split /\s*\|\s*/, $_;
125218eb
NC
114 my $func = $args[2];
115 if ($func) {
116 ++$has_va{$func} if $args[-1] =~ /\.\.\./;
117 ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
118 }
881a2100
NC
119 }
120 push @embed, \@args;
121}
122
cea2e8a9
GS
123# walk table providing an array of components in each line to
124# subroutine, printing the result
125sub walk_table (&@) {
2f208540 126 my ($function, $filename, $leader, $trailer) = @_;
0ea9712b 127 defined $leader or $leader = do_not_edit ($filename);
cea2e8a9 128 my $F;
cea2e8a9
GS
129 if (ref $filename) { # filehandle
130 $F = $filename;
131 }
132 else {
b6b9a099 133 # safer_unlink $filename if $filename ne '/dev/null';
424a4936 134 $F = safer_open("$filename-new");
cea2e8a9
GS
135 }
136 print $F $leader if $leader;
881a2100
NC
137 foreach (@embed) {
138 my @outs = &{$function}(@$_);
4373e329 139 print $F @outs; # $function->(@args) is not 5.003
cea2e8a9
GS
140 }
141 print $F $trailer if $trailer;
36bb303b 142 unless (ref $filename) {
08858ed2 143 safer_close($F);
424a4936 144 rename_if_different("$filename-new", $filename);
36bb303b 145 }
cea2e8a9
GS
146}
147
148sub munge_c_files () {
149 my $functions = {};
150 unless (@ARGV) {
4373e329 151 warn "\@ARGV empty, nothing to do\n";
cea2e8a9
GS
152 return;
153 }
154 walk_table {
155 if (@_ > 1) {
156 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
157 }
37442d52 158 } '/dev/null', '', '';
cea2e8a9
GS
159 local $^I = '.bak';
160 while (<>) {
cea2e8a9
GS
161 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
162 {
163 my $repl = $1;
164 my $f = $2;
165 if (exists $functions->{$f}) {
166 $repl .= "aTHX_ ";
167 warn("$ARGV:$.:$`#$repl#$'");
168 }
169 $repl;
170 }eg;
171 print;
172 close ARGV if eof; # restart $.
173 }
174 exit;
175}
176
177#munge_c_files();
178
179# generate proto.h
0cb96387
GS
180my $wrote_protected = 0;
181
cea2e8a9
GS
182sub write_protos {
183 my $ret = "";
184 if (@_ == 1) {
185 my $arg = shift;
1d7c1841 186 $ret .= "$arg\n";
cea2e8a9
GS
187 }
188 else {
7918f24d 189 my ($flags,$retval,$plain_func,@args) = @_;
4373e329
AL
190 my @nonnull;
191 my $has_context = ( $flags !~ /n/ );
88e01c9d
AL
192 my $never_returns = ( $flags =~ /r/ );
193 my $commented_out = ( $flags =~ /m/ );
aa4ca557 194 my $binarycompat = ( $flags =~ /b/ );
88e01c9d
AL
195 my $is_malloc = ( $flags =~ /a/ );
196 my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
7918f24d
NC
197 my @names_of_nn;
198 my $func;
88e01c9d
AL
199
200 my $splint_flags = "";
201 if ( $SPLINT && !$commented_out ) {
202 $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
203 if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
204 $retval .= " /*\@alt void\@*/";
205 }
206 }
207
cea2e8a9 208 if ($flags =~ /s/) {
88e01c9d 209 $retval = "STATIC $splint_flags$retval";
7918f24d 210 $func = "S_$plain_func";
cea2e8a9 211 }
0cb96387 212 else {
88e01c9d 213 $retval = "PERL_CALLCONV $splint_flags$retval";
25b0f989 214 if ($flags =~ /[bp]/) {
7918f24d
NC
215 $func = "Perl_$plain_func";
216 } else {
217 $func = $plain_func;
0cb96387 218 }
cea2e8a9
GS
219 }
220 $ret .= "$retval\t$func(";
4373e329
AL
221 if ( $has_context ) {
222 $ret .= @args ? "pTHX_ " : "pTHX";
cea2e8a9
GS
223 }
224 if (@args) {
4373e329
AL
225 my $n;
226 for my $arg ( @args ) {
227 ++$n;
7827dc65
AL
228 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
229 warn "$func: $arg needs NN or NULLOK\n";
230 our $unflagged_pointers;
231 ++$unflagged_pointers;
232 }
88e01c9d
AL
233 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
234 push( @nonnull, $n ) if $nn;
235
236 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
c48640ec
AL
237
238 # Make sure each arg has at least a type and a var name.
239 # An arg of "int" is valid C, but want it to be "int foo".
240 my $temp_arg = $arg;
241 $temp_arg =~ s/\*//g;
242 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
7918f24d
NC
243 if ( ($temp_arg ne "...")
244 && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
245 warn "$func: $arg ($n) doesn't have a name\n";
c48640ec 246 }
88e01c9d
AL
247 if ( $SPLINT && $nullok && !$commented_out ) {
248 $arg = '/*@null@*/ ' . $arg;
249 }
aa4ca557 250 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
7918f24d
NC
251 push @names_of_nn, $1;
252 }
4373e329 253 }
cea2e8a9
GS
254 $ret .= join ", ", @args;
255 }
256 else {
4373e329 257 $ret .= "void" if !$has_context;
cea2e8a9
GS
258 }
259 $ret .= ")";
f54cb97a
AL
260 my @attrs;
261 if ( $flags =~ /r/ ) {
abb2c242 262 push @attrs, "__attribute__noreturn__";
f54cb97a 263 }
a5c26493
RGS
264 if ( $flags =~ /D/ ) {
265 push @attrs, "__attribute__deprecated__";
266 }
88e01c9d 267 if ( $is_malloc ) {
abb2c242 268 push @attrs, "__attribute__malloc__";
f54cb97a 269 }
88e01c9d 270 if ( !$can_ignore ) {
abb2c242 271 push @attrs, "__attribute__warn_unused_result__";
f54cb97a
AL
272 }
273 if ( $flags =~ /P/ ) {
abb2c242 274 push @attrs, "__attribute__pure__";
f54cb97a 275 }
1c846c1f 276 if( $flags =~ /f/ ) {
cdfeb707
RB
277 my $prefix = $has_context ? 'pTHX_' : '';
278 my $args = scalar @args;
279 my $pat = $args - 1;
280 my $macro = @nonnull && $nonnull[-1] == $pat
281 ? '__attribute__format__'
282 : '__attribute__format__null_ok__';
283 push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
284 $prefix, $pat, $prefix, $args;
894356b3 285 }
4373e329 286 if ( @nonnull ) {
3d42dc86 287 my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
abb2c242 288 push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
f54cb97a
AL
289 }
290 if ( @attrs ) {
291 $ret .= "\n";
292 $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
4373e329 293 }
af3c7592 294 $ret .= ";";
88e01c9d 295 $ret = "/* $ret */" if $commented_out;
7918f24d
NC
296 if (@names_of_nn) {
297 $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
298 . join '; ', map "assert($_)", @names_of_nn;
299 }
f54cb97a 300 $ret .= @attrs ? "\n\n" : "\n";
cea2e8a9
GS
301 }
302 $ret;
303}
304
2b10efc6
NC
305# generates global.sym (API export list)
306{
307 my %seen;
308 sub write_global_sym {
309 my $ret = "";
310 if (@_ > 1) {
311 my ($flags,$retval,$func,@args) = @_;
312 # If a function is defined twice, for example before and after an
313 # #else, only process the flags on the first instance for global.sym
314 return $ret if $seen{$func}++;
315 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
316 || $flags =~ /b/) { # public API, so export
317 $func = "Perl_$func" if $flags =~ /[pbX]/;
318 $ret = "$func\n";
319 }
320 }
321 $ret;
322 }
cea2e8a9
GS
323}
324
2b10efc6 325
7827dc65 326our $unflagged_pointers;
37442d52 327walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n");
7827dc65 328warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
37442d52 329walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
cea2e8a9 330
709f4e38
GS
331# XXX others that may need adding
332# warnhook
333# hints
334# copline
84fee439 335my @extvars = qw(sv_undef sv_yes sv_no na dowarn
4373e329
AL
336 curcop compiling
337 tainting tainted stack_base stack_sp sv_arenaroot
256a4781 338 no_modify
4373e329
AL
339 curstash DBsub DBsingle DBassertion debstash
340 rsfp
341 stdingv
6b88bc9c
GS
342 defgv
343 errgv
3070f6ec
GS
344 rsfp_filters
345 perldb
709f4e38
GS
346 diehook
347 dirty
348 perl_destruct_level
ac634a9a 349 ppaddr
84fee439
NIS
350 );
351
5f05dabc
PP
352sub readsyms (\%$) {
353 my ($syms, $file) = @_;
5f05dabc
PP
354 local (*FILE, $_);
355 open(FILE, "< $file")
356 or die "embed.pl: Can't open $file: $!\n";
357 while (<FILE>) {
358 s/[ \t]*#.*//; # Delete comments.
359 if (/^\s*(\S+)\s*$/) {
22c35a8c 360 my $sym = $1;
d1594dd0 361 warn "duplicate symbol $sym while processing $file line $.\n"
22c35a8c
GS
362 if exists $$syms{$sym};
363 $$syms{$sym} = 1;
5f05dabc
PP
364 }
365 }
366 close(FILE);
367}
368
cea2e8a9
GS
369# Perl_pp_* and Perl_ck_* are in pp.sym
370readsyms my %ppsym, 'pp.sym';
5f05dabc 371
c6af7a1a
GS
372sub readvars(\%$$@) {
373 my ($syms, $file,$pre,$keep_pre) = @_;
d4cce5f1
NIS
374 local (*FILE, $_);
375 open(FILE, "< $file")
376 or die "embed.pl: Can't open $file: $!\n";
377 while (<FILE>) {
378 s/[ \t]*#.*//; # Delete comments.
27da23d5 379 if (/PERLVARA?I?S?C?\($pre(\w+)/) {
22c35a8c 380 my $sym = $1;
c6af7a1a 381 $sym = $pre . $sym if $keep_pre;
d1594dd0 382 warn "duplicate symbol $sym while processing $file line $.\n"
22c35a8c 383 if exists $$syms{$sym};
51371543 384 $$syms{$sym} = $pre || 1;
d4cce5f1
NIS
385 }
386 }
387 close(FILE);
388}
389
390my %intrp;
88e01c9d 391my %globvar;
d4cce5f1
NIS
392
393readvars %intrp, 'intrpvar.h','I';
22239a37 394readvars %globvar, 'perlvars.h','G';
d4cce5f1 395
4543f4c0 396my $sym;
d4cce5f1 397
c6af7a1a
GS
398sub undefine ($) {
399 my ($sym) = @_;
400 "#undef $sym\n";
401}
402
125218eb
NC
403sub hide {
404 my ($from, $to, $indent) = @_;
405 $indent = '' unless defined $indent;
406 my $t = int(length("$indent$from") / 8);
407 "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
5f05dabc 408}
c6af7a1a 409
6f4183fe 410sub bincompat_var ($$) {
51371543 411 my ($pfx, $sym) = @_;
acfe0abc 412 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
c5be433b 413 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
c6af7a1a
GS
414}
415
d4cce5f1
NIS
416sub multon ($$$) {
417 my ($sym,$pre,$ptr) = @_;
3280af22 418 hide("PL_$sym", "($ptr$pre$sym)");
5f05dabc 419}
54aff467 420
d4cce5f1
NIS
421sub multoff ($$) {
422 my ($sym,$pre) = @_;
533c011a 423 return hide("PL_$pre$sym", "PL_$sym");
5f05dabc
PP
424}
425
424a4936 426my $em = safer_open('embed.h-new');
e50aee73 427
424a4936 428print $em do_not_edit ("embed.h"), <<'END';
e50aee73
AD
429
430/* (Doing namespace management portably in C is really gross.) */
431
d51482e4
JH
432/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
433 * (like warn instead of Perl_warn) for the API are not defined.
434 * Not defining the short forms is a good thing for cleaner embedding. */
435
436#ifndef PERL_NO_SHORT_NAMES
820c3be9 437
22c35a8c 438/* Hide global symbols */
5f05dabc 439
cea2e8a9 440#if !defined(PERL_IMPLICIT_CONTEXT)
e50aee73 441
e50aee73
AD
442END
443
da4ddda1
NC
444# Try to elimiate lots of repeated
445# #ifdef PERL_CORE
446# foo
447# #endif
448# #ifdef PERL_CORE
449# bar
450# #endif
451# by tracking state and merging foo and bar into one block.
452my $ifdef_state = '';
453
cea2e8a9
GS
454walk_table {
455 my $ret = "";
da4ddda1 456 my $new_ifdef_state = '';
cea2e8a9
GS
457 if (@_ == 1) {
458 my $arg = shift;
12a98ad5 459 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
cea2e8a9
GS
460 }
461 else {
462 my ($flags,$retval,$func,@args) = @_;
af3c7592 463 unless ($flags =~ /[om]/) {
cea2e8a9
GS
464 if ($flags =~ /s/) {
465 $ret .= hide($func,"S_$func");
466 }
467 elsif ($flags =~ /p/) {
468 $ret .= hide($func,"Perl_$func");
469 }
470 }
47e67c64 471 if ($ret ne '' && $flags !~ /A/) {
de37762f 472 if ($flags =~ /E/) {
da4ddda1
NC
473 $new_ifdef_state
474 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
475 }
476 else {
477 $new_ifdef_state = "#ifdef PERL_CORE\n";
478 }
479
480 if ($new_ifdef_state ne $ifdef_state) {
481 $ret = $new_ifdef_state . $ret;
de37762f
HS
482 }
483 }
cea2e8a9 484 }
da4ddda1
NC
485 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
486 # Close the old one ahead of opening the new one.
487 $ret = "#endif\n$ret";
488 }
489 # Remember the new state.
490 $ifdef_state = $new_ifdef_state;
cea2e8a9 491 $ret;
424a4936 492} $em, "";
cea2e8a9 493
da4ddda1 494if ($ifdef_state) {
424a4936 495 print $em "#endif\n";
da4ddda1
NC
496}
497
cea2e8a9
GS
498for $sym (sort keys %ppsym) {
499 $sym =~ s/^Perl_//;
424a4936 500 print $em hide($sym, "Perl_$sym");
cea2e8a9
GS
501}
502
424a4936 503print $em <<'END';
cea2e8a9
GS
504
505#else /* PERL_IMPLICIT_CONTEXT */
506
507END
508
509my @az = ('a'..'z');
510
da4ddda1 511$ifdef_state = '';
cea2e8a9
GS
512walk_table {
513 my $ret = "";
da4ddda1 514 my $new_ifdef_state = '';
cea2e8a9
GS
515 if (@_ == 1) {
516 my $arg = shift;
12a98ad5 517 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
cea2e8a9
GS
518 }
519 else {
520 my ($flags,$retval,$func,@args) = @_;
af3c7592 521 unless ($flags =~ /[om]/) {
cea2e8a9
GS
522 my $args = scalar @args;
523 if ($args and $args[$args-1] =~ /\.\.\./) {
524 # we're out of luck for varargs functions under CPP
525 }
526 elsif ($flags =~ /n/) {
527 if ($flags =~ /s/) {
528 $ret .= hide($func,"S_$func");
529 }
530 elsif ($flags =~ /p/) {
531 $ret .= hide($func,"Perl_$func");
532 }
533 }
534 else {
535 my $alist = join(",", @az[0..$args-1]);
536 $ret = "#define $func($alist)";
537 my $t = int(length($ret) / 8);
538 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
539 if ($flags =~ /s/) {
540 $ret .= "S_$func(aTHX";
541 }
542 elsif ($flags =~ /p/) {
543 $ret .= "Perl_$func(aTHX";
544 }
545 $ret .= "_ " if $alist;
546 $ret .= $alist . ")\n";
547 }
548 }
da4ddda1 549 unless ($flags =~ /A/) {
de37762f 550 if ($flags =~ /E/) {
da4ddda1
NC
551 $new_ifdef_state
552 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
553 }
554 else {
555 $new_ifdef_state = "#ifdef PERL_CORE\n";
556 }
557
558 if ($new_ifdef_state ne $ifdef_state) {
559 $ret = $new_ifdef_state . $ret;
de37762f
HS
560 }
561 }
cea2e8a9 562 }
da4ddda1
NC
563 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
564 # Close the old one ahead of opening the new one.
565 $ret = "#endif\n$ret";
566 }
567 # Remember the new state.
568 $ifdef_state = $new_ifdef_state;
cea2e8a9 569 $ret;
424a4936 570} $em, "";
cea2e8a9 571
da4ddda1 572if ($ifdef_state) {
424a4936 573 print $em "#endif\n";
da4ddda1
NC
574}
575
cea2e8a9
GS
576for $sym (sort keys %ppsym) {
577 $sym =~ s/^Perl_//;
578 if ($sym =~ /^ck_/) {
424a4936 579 print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
cea2e8a9
GS
580 }
581 elsif ($sym =~ /^pp_/) {
424a4936 582 print $em hide("$sym()", "Perl_$sym(aTHX)");
cea2e8a9
GS
583 }
584 else {
585 warn "Illegal symbol '$sym' in pp.sym";
586 }
e50aee73
AD
587}
588
424a4936 589print $em <<'END';
e50aee73 590
cea2e8a9 591#endif /* PERL_IMPLICIT_CONTEXT */
22c35a8c 592
d51482e4 593#endif /* #ifndef PERL_NO_SHORT_NAMES */
35209cc8 594
22c35a8c
GS
595END
596
424a4936 597print $em <<'END';
22c35a8c 598
cea2e8a9
GS
599/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
600 disable them.
601 */
602
538feb02 603#if !defined(PERL_CORE)
5bc28da9 604# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
a0714e2c 605# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
538feb02 606#endif
cea2e8a9 607
08e5223a 608#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
cea2e8a9
GS
609
610/* Compatibility for various misnamed functions. All functions
611 in the API that begin with "perl_" (not "Perl_") take an explicit
612 interpreter context pointer.
613 The following are not like that, but since they had a "perl_"
614 prefix in previous versions, we provide compatibility macros.
615 */
65cec589 616# define perl_atexit(a,b) call_atexit(a,b)
7b53c8ee
NC
617END
618
619walk_table {
620 my ($flags,$retval,$func,@args) = @_;
621 return unless $func;
622 return unless $flags =~ /O/;
623
624 my $alist = join ",", @az[0..$#args];
625 my $ret = "# define perl_$func($alist)";
626 my $t = (length $ret) >> 3;
627 $ret .= "\t" x ($t < 5 ? 5 - $t : 1);
628 "$ret$func($alist)\n";
629} $em, "";
630
631print $em <<'END';
cea2e8a9
GS
632
633/* varargs functions can't be handled with CPP macros. :-(
634 This provides a set of compatibility functions that don't take
635 an extra argument but grab the context pointer using the macro
636 dTHX.
637 */
d51482e4 638#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
125218eb
NC
639END
640
641foreach (sort keys %has_va) {
642 next unless $has_nocontext{$_};
643 next if /printf/; # Not clear to me why these are skipped but they are.
644 print $em hide($_, "Perl_${_}_nocontext", " ");
645}
646
647print $em <<'END';
cea2e8a9
GS
648#endif
649
650#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
651
652#if !defined(PERL_IMPLICIT_CONTEXT)
653/* undefined symbols, point them back at the usual ones */
125218eb
NC
654END
655
656foreach (sort keys %has_va) {
657 next unless $has_nocontext{$_};
658 next if /printf/; # Not clear to me why these are skipped but they are.
659 print $em hide("Perl_${_}_nocontext", "Perl_$_", " ");
660}
661
662print $em <<'END';
cea2e8a9 663#endif
db5cf5a9 664
37442d52 665/* ex: set ro: */
d4cce5f1
NIS
666END
667
08858ed2 668safer_close($em);
424a4936 669rename_if_different('embed.h-new', 'embed.h');
d4cce5f1 670
424a4936 671$em = safer_open('embedvar.h-new');
d4cce5f1 672
424a4936 673print $em do_not_edit ("embedvar.h"), <<'END';
d4cce5f1
NIS
674
675/* (Doing namespace management portably in C is really gross.) */
676
54aff467 677/*
3db8f154
MB
678 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
679 are supported:
54aff467
GS
680 1) none
681 2) MULTIPLICITY # supported for compatibility
682 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
54aff467
GS
683
684 All other combinations of these flags are errors.
685
3db8f154 686 only #3 is supported directly, while #2 is a special
54aff467
GS
687 case of #3 (supported by redefining vTHX appropriately).
688*/
cea2e8a9 689
54aff467 690#if defined(MULTIPLICITY)
3db8f154 691/* cases 2 and 3 above */
cea2e8a9 692
54aff467
GS
693# if defined(PERL_IMPLICIT_CONTEXT)
694# define vTHX aTHX
695# else
696# define vTHX PERL_GET_INTERP
697# endif
cea2e8a9 698
e50aee73
AD
699END
700
d4cce5f1 701for $sym (sort keys %intrp) {
424a4936 702 print $em multon($sym,'I','vTHX->');
d4cce5f1
NIS
703}
704
424a4936 705print $em <<'END';
d4cce5f1 706
54aff467 707#else /* !MULTIPLICITY */
1d7c1841 708
3db8f154 709/* case 1 above */
5f05dabc 710
56d28764 711END
e50aee73 712
d4cce5f1 713for $sym (sort keys %intrp) {
424a4936 714 print $em multoff($sym,'I');
d4cce5f1
NIS
715}
716
424a4936 717print $em <<'END';
d4cce5f1 718
d4cce5f1
NIS
719END
720
424a4936 721print $em <<'END';
d4cce5f1 722
54aff467 723#endif /* MULTIPLICITY */
d4cce5f1 724
54aff467 725#if defined(PERL_GLOBAL_STRUCT)
22239a37
NIS
726
727END
728
729for $sym (sort keys %globvar) {
424a4936
NC
730 print $em multon($sym, 'G','my_vars->');
731 print $em multon("G$sym",'', 'my_vars->');
22239a37
NIS
732}
733
424a4936 734print $em <<'END';
22239a37
NIS
735
736#else /* !PERL_GLOBAL_STRUCT */
737
738END
739
740for $sym (sort keys %globvar) {
424a4936 741 print $em multoff($sym,'G');
22239a37
NIS
742}
743
424a4936 744print $em <<'END';
22239a37 745
22239a37
NIS
746#endif /* PERL_GLOBAL_STRUCT */
747
37442d52 748/* ex: set ro: */
84fee439
NIS
749END
750
08858ed2 751safer_close($em);
424a4936 752rename_if_different('embedvar.h-new', 'embedvar.h');
c6af7a1a 753
424a4936
NC
754my $capi = safer_open('perlapi.c-new');
755my $capih = safer_open('perlapi.h-new');
51371543 756
424a4936 757print $capih do_not_edit ("perlapi.h"), <<'EOT';
51371543 758
51371543 759/* declare accessor functions for Perl variables */
6f4183fe
GS
760#ifndef __perlapi_h__
761#define __perlapi_h__
51371543 762
87b9e160 763#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
c5be433b 764
51371543
GS
765START_EXTERN_C
766
767#undef PERLVAR
768#undef PERLVARA
769#undef PERLVARI
770#undef PERLVARIC
27da23d5 771#undef PERLVARISC
acfe0abc 772#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
51371543 773#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
acfe0abc 774 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
51371543 775#define PERLVARI(v,t,i) PERLVAR(v,t)
c5be433b 776#define PERLVARIC(v,t,i) PERLVAR(v, const t)
27da23d5
JH
777#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
778 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
51371543 779
51371543
GS
780#include "perlvars.h"
781
782#undef PERLVAR
783#undef PERLVARA
784#undef PERLVARI
785#undef PERLVARIC
27da23d5
JH
786#undef PERLVARISC
787
51371543
GS
788END_EXTERN_C
789
682fc664 790#if defined(PERL_CORE)
6f4183fe 791
87b9e160 792/* accessor functions for Perl "global" variables */
682fc664
GS
793
794/* these need to be mentioned here, or most linkers won't put them in
795 the perl executable */
796
797#ifndef PERL_NO_FORCE_LINK
798
799START_EXTERN_C
800
801#ifndef DOINIT
27da23d5 802EXTCONST void * const PL_force_link_funcs[];
682fc664 803#else
27da23d5 804EXTCONST void * const PL_force_link_funcs[] = {
682fc664
GS
805#undef PERLVAR
806#undef PERLVARA
807#undef PERLVARI
808#undef PERLVARIC
ea1f607c 809#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
682fc664
GS
810#define PERLVARA(v,n,t) PERLVAR(v,t)
811#define PERLVARI(v,t,i) PERLVAR(v,t)
812#define PERLVARIC(v,t,i) PERLVAR(v,t)
27da23d5 813#define PERLVARISC(v,i) PERLVAR(v,char)
682fc664 814
3c0f78ca
JH
815/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
816 * cannot cast between void pointers and function pointers without
817 * info level warnings. The PL_force_link_funcs[] would cause a few
818 * hundred of those warnings. In code one can circumnavigate this by using
819 * unions that overlay the different pointers, but in declarations one
820 * cannot use this trick. Therefore we just disable the warning here
821 * for the duration of the PL_force_link_funcs[] declaration. */
822
823#if defined(__DECC) && defined(__osf__)
824#pragma message save
825#pragma message disable (nonstandcast)
826#endif
827
682fc664
GS
828#include "perlvars.h"
829
3c0f78ca
JH
830#if defined(__DECC) && defined(__osf__)
831#pragma message restore
832#endif
833
682fc664
GS
834#undef PERLVAR
835#undef PERLVARA
836#undef PERLVARI
837#undef PERLVARIC
27da23d5 838#undef PERLVARISC
682fc664
GS
839};
840#endif /* DOINIT */
841
acfe0abc 842END_EXTERN_C
682fc664
GS
843
844#endif /* PERL_NO_FORCE_LINK */
845
846#else /* !PERL_CORE */
51371543
GS
847
848EOT
849
4543f4c0 850foreach $sym (sort keys %globvar) {
424a4936 851 print $capih bincompat_var('G',$sym);
6f4183fe
GS
852}
853
424a4936 854print $capih <<'EOT';
6f4183fe
GS
855
856#endif /* !PERL_CORE */
87b9e160 857#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
6f4183fe
GS
858
859#endif /* __perlapi_h__ */
860
37442d52 861/* ex: set ro: */
6f4183fe 862EOT
08858ed2 863safer_close($capih);
424a4936 864rename_if_different('perlapi.h-new', 'perlapi.h');
51371543 865
424a4936 866print $capi do_not_edit ("perlapi.c"), <<'EOT';
51371543
GS
867
868#include "EXTERN.h"
869#include "perl.h"
870#include "perlapi.h"
871
87b9e160 872#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
51371543 873
87b9e160 874/* accessor functions for Perl "global" variables */
51371543
GS
875START_EXTERN_C
876
51371543 877#undef PERLVARI
87b9e160 878#define PERLVARI(v,t,i) PERLVAR(v,t)
c5be433b
GS
879
880#undef PERLVAR
881#undef PERLVARA
acfe0abc 882#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
96a5add6 883 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
acfe0abc 884#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
96a5add6 885 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
34f7a5fe 886#undef PERLVARIC
27da23d5
JH
887#undef PERLVARISC
888#define PERLVARIC(v,t,i) \
889 const t* Perl_##v##_ptr(pTHX) \
96a5add6 890 { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
27da23d5 891#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
96a5add6 892 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
51371543
GS
893#include "perlvars.h"
894
895#undef PERLVAR
896#undef PERLVARA
897#undef PERLVARI
898#undef PERLVARIC
27da23d5
JH
899#undef PERLVARISC
900
acfe0abc 901END_EXTERN_C
6f4183fe 902
87b9e160 903#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
37442d52
RGS
904
905/* ex: set ro: */
51371543
GS
906EOT
907
08858ed2 908safer_close($capi);
424a4936 909rename_if_different('perlapi.c-new', 'perlapi.c');
acfe0abc 910
1b6737cc 911# ex: set ts=8 sts=4 sw=4 noet: