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