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