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