X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/af00134636ffe4172cbffeaed3bbad802e58d8a0..7dc0f1bb7f6dd199fb0aae6f5edfa264e67a051a:/regen/embed.pl diff --git a/regen/embed.pl b/regen/embed.pl index 3aae2cd..5c33127 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -1,10 +1,9 @@ #!/usr/bin/perl -w -# +# # Regenerate (overwriting only if changed): # # embed.h # embedvar.h -# global.sym # perlapi.c # perlapi.h # proto.h @@ -14,7 +13,7 @@ # embed.fnc # intrpvar.h # perlvars.h -# pp.sym (which has been generated by opcode.pl) +# regen/opcodes # # Accepts the standard regen_lib -q and -v args. # @@ -27,10 +26,10 @@ use strict; BEGIN { # Get function prototypes - require 'regen/regen_lib.pl'; + require './regen/regen_lib.pl'; + require './regen/embed_lib.pl'; } -my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org my $unflagged_pointers; # @@ -40,266 +39,131 @@ my $unflagged_pointers; # implicit interpreter context argument. # -sub do_not_edit ($) -{ - my $file = shift; - - my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009'; - - $years =~ s/1999,/1999,\n / if length $years > 40; - - my $warning = <) { - chomp; - next if /^:/; - next if /^$/; - while (s|\\$||) { - $_ .= ; - chomp; - } - s/\s+$//; - my @args; - if (/^\s*(#|$)/) { - @args = $_; - } - else { - @args = split /\s*\|\s*/, $_; - my $func = $args[2]; - if ($func) { - ++$has_va{$func} if $args[-1] =~ /\.\.\./; - ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/; - } - } - if (@args == 1 && $args[0] !~ /^#\s*(?:if|ifdef|ifndef|else|endif)/) { - die "Illegal line $. '$args[0]' in embed.fnc"; - } - push @embed, \@args; +my $error_count = 0; +sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't + # succeed. + warn shift; + $error_count++; } -open IN, 'pp.sym' or die $!; -{ - my %syms; - - while () { - s/[ \t]*#.*//; # Delete comments. - if (/^\s*(\S+)\s*$/) { - my $sym = $1; - warn "duplicate symbol $sym while processing 'pp.sym' line $.\n" - if $syms{$sym}++; - } - } +sub full_name ($$) { # Returns the function name with potentially the + # prefixes 'S_' or 'Perl_' + my ($func, $flags) = @_; - foreach (sort keys %syms) { - s/^Perl_//; - if (/^ck_/) { - # These are all indirectly referenced by globals.c. - # This is somewhat annoying. - push @embed, ['pR', 'OP *', $_, 'NN OP *o']; - } - elsif (/^pp_/) { - push @embed, ['p', 'OP *', $_]; - } - else { - warn "Illegal symbol '$_' in pp.sym"; - } - } + return "Perl_$func" if $flags =~ /p/; + return "S_$func" if $flags =~ /[SIi]/; + return $func; } -close IN; -my (@core, @ext, @api); -{ - # Cluster entries in embed.fnc that have the same #ifdef guards. - # Also, split out at the top level the three classes of functions. - my @state; - my %groups; - my $current; - foreach (@embed) { - if (@$_ > 1) { - push @$current, $_; - next; - } - $_->[0] =~ s/^#\s+/#/; - $_->[0] =~ /^\S*/; - $_->[0] =~ s/^#ifdef\s+(\S+)/#if defined($1)/; - $_->[0] =~ s/^#ifndef\s+(\S+)/#if !defined($1)/; - if ($_->[0] =~ /^#if\s*(.*)/) { - push @state, $1; - } elsif ($_->[0] =~ /^#else\s*$/) { - die "Unmatched #else in embed.fnc" unless @state; - $state[-1] = "!($state[-1])"; - } elsif ($_->[0] =~ m!^#endif\s*(?:/\*.*\*/)?$!) { - die "Unmatched #endif in embed.fnc" unless @state; - pop @state; - } else { - die "Unhandled pre-processor directive '$_->[0]' in embed.fnc"; - } - $current = \%groups; - # Nested #if blocks are effectively &&ed together - # For embed.fnc, ordering withing the && isn't relevant, so we can - # sort them to try to group more functions together. - my @sorted = sort @state; - while (my $directive = shift @sorted) { - $current->{$directive} ||= {}; - $current = $current->{$directive}; - } - $current->{''} ||= []; - $current = $current->{''}; - } +sub open_print_header { + my ($file, $quote) = @_; - sub add_level { - my ($level, $indent, $wanted) = @_; - my $funcs = $level->{''}; - my @entries; - if ($funcs) { - if (!defined $wanted) { - @entries = @$funcs; - } else { - foreach (@$funcs) { - if ($_->[0] =~ /A/) { - push @entries, $_ if $wanted eq 'A'; - } elsif ($_->[0] =~ /E/) { - push @entries, $_ if $wanted eq 'E'; - } else { - push @entries, $_ if $wanted eq ''; - } - } - } - @entries = sort {$a->[2] cmp $b->[2]} @entries; - } - foreach (sort grep {length $_} keys %$level) { - my @conditional = add_level($level->{$_}, $indent . ' ', $wanted); - push @entries, - ["#${indent}if $_"], @conditional, ["#${indent}endif"] - if @conditional; - } - return @entries; - } - @core = add_level(\%groups, '', ''); - @ext = add_level(\%groups, '', 'E'); - @api = add_level(\%groups, '', 'A'); - - @embed = add_level(\%groups, ''); + return open_new($file, '>', + { file => $file, style => '*', by => 'regen/embed.pl', + from => ['data in embed.fnc', 'regen/embed.pl', + 'regen/opcodes', 'intrpvar.h', 'perlvars.h'], + final => "\nEdit those files and run 'make regen_headers' to effect changes.\n", + copyright => [1993 .. 2009], quote => $quote }); } -# walk table providing an array of components in each line to -# subroutine, printing the result -sub walk_table (&@) { - my ($function, $filename, $trailer) = @_; - my $F; - if (ref $filename) { # filehandle - $F = $filename; - } - else { - $F = safer_open("$filename-new"); - print $F do_not_edit ($filename); - } - foreach (@embed) { - my @outs = &{$function}(@$_); - # $function->(@args) is not 5.003 - print $F @outs; - } - print $F $trailer if $trailer; - unless (ref $filename) { - safer_close($F); - rename_if_different("$filename-new", $filename); - } -} +my ($embed, $core, $ext, $api) = setup_embed(); # generate proto.h { - my $pr = safer_open('proto.h-new'); - print $pr do_not_edit ("proto.h"), "\nSTART_EXTERN_C\n"; + my $pr = open_print_header("proto.h"); + print $pr "START_EXTERN_C\n"; my $ret; - foreach (@embed) { + foreach (@$embed) { if (@$_ == 1) { print $pr "$_->[0]\n"; next; } my ($flags,$retval,$plain_func,@args) = @$_; + if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx] ) /x) { + die_at_end "flag $1 is not legal (for function $plain_func)"; + } my @nonnull; - my $has_context = ( $flags !~ /n/ ); + my $args_assert_line = ( $flags !~ /G/ ); + my $has_depth = ( $flags =~ /W/ ); + my $has_context = ( $flags !~ /T/ ); my $never_returns = ( $flags =~ /r/ ); - my $commented_out = ( $flags =~ /m/ ); my $binarycompat = ( $flags =~ /b/ ); + my $commented_out = ( $flags =~ /m/ ); my $is_malloc = ( $flags =~ /a/ ); - my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc; + my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc; my @names_of_nn; my $func; - my $splint_flags = ""; - if ( $SPLINT && !$commented_out ) { - $splint_flags .= '/*@noreturn@*/ ' if $never_returns; - if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) { - $retval .= " /*\@alt void\@*/"; - } + if (! $can_ignore && $retval eq 'void') { + warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked"; } - if ($flags =~ /s/) { - $retval = "STATIC $splint_flags$retval"; - $func = "S_$plain_func"; + die_at_end "$plain_func: S and p flags are mutually exclusive" + if $flags =~ /S/ && $flags =~ /p/; + die_at_end "$plain_func: m and $1 flags are mutually exclusive" + if $flags =~ /m/ && $flags =~ /([pS])/; + + die_at_end "$plain_func: u flag only usable with m" if $flags =~ /u/ + && $flags !~ /m/; + + my $static_inline = 0; + if ($flags =~ /([SIi])/) { + my $type; + if ($never_returns) { + $type = { + 'S' => 'PERL_STATIC_NO_RET', + 'i' => 'PERL_STATIC_INLINE_NO_RET', + 'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET' + }->{$1}; + } + else { + $type = { + 'S' => 'STATIC', + 'i' => 'PERL_STATIC_INLINE', + 'I' => 'PERL_STATIC_FORCE_INLINE' + }->{$1}; + } + $retval = "$type $retval"; + die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/; + $static_inline = $type =~ /^PERL_STATIC(?:_FORCE)?_INLINE/; } else { - $retval = "PERL_CALLCONV $splint_flags$retval"; - if ($flags =~ /[bp]/) { - $func = "Perl_$plain_func"; - } else { - $func = $plain_func; + if ($never_returns) { + $retval = "PERL_CALLCONV_NO_RET $retval"; + } + else { + $retval = "PERL_CALLCONV $retval"; } } - $ret = "$retval\t$func("; + + die_at_end "For '$plain_func', M flag requires p flag" + if $flags =~ /M/ && $flags !~ /p/; + die_at_end "For '$plain_func', C flag requires one of [pIimb] flags" + if $flags =~ /C/ && $flags !~ /[Iibmp]/; + die_at_end "For '$plain_func', X flag requires one of [Iip] flags" + if $flags =~ /X/ && $flags !~ /[Iip]/; + die_at_end "For '$plain_func', X and m flags are mutually exclusive" + if $flags =~ /X/ && $flags =~ /m/; + die_at_end "For '$plain_func', [Ii] with [ACX] requires p flag" + if $flags =~ /[Ii]/ && $flags =~ /[ACX]/ && $flags !~ /p/; + die_at_end "For '$plain_func', b and m flags are mutually exclusive" + . " (try M flag)" if $flags =~ /b/ && $flags =~ /m/; + die_at_end "For '$plain_func', b flag without M flag requires D flag" + if $flags =~ /b/ && $flags !~ /M/ && $flags !~ /D/; + die_at_end "For '$plain_func', I and i flags are mutually exclusive" + if $flags =~ /I/ && $flags =~ /i/; + + $func = full_name($plain_func, $flags); + $ret = ""; + $ret .= "$retval\t$func("; if ( $has_context ) { $ret .= @args ? "pTHX_ " : "pTHX"; } if (@args) { + die_at_end "n flag is contradicted by having arguments" + if $flags =~ /n/; my $n; for my $arg ( @args ) { ++$n; @@ -319,10 +183,7 @@ sub walk_table (&@) { $temp_arg =~ s/\s*\bstruct\b\s*/ /g; if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { - warn "$func: $arg ($n) doesn't have a name\n"; - } - if ( $SPLINT && $nullok && !$commented_out ) { - $arg = '/*@null@*/ ' . $arg; + die_at_end "$func: $arg ($n) doesn't have a name\n"; } if (defined $1 && $nn && !($commented_out && !$binarycompat)) { push @names_of_nn, $1; @@ -333,6 +194,7 @@ sub walk_table (&@) { else { $ret .= "void" if !$has_context; } + $ret .= " _pDEPTH" if $has_depth; $ret .= ")"; my @attrs; if ( $flags =~ /r/ ) { @@ -350,19 +212,41 @@ sub walk_table (&@) { if ( $flags =~ /P/ ) { push @attrs, "__attribute__pure__"; } + if ( $flags =~ /I/ ) { + push @attrs, "__attribute__always_inline__"; + } if( $flags =~ /f/ ) { my $prefix = $has_context ? 'pTHX_' : ''; - my $args = scalar @args; - my $pat = $args - 1; - my $macro = @nonnull && $nonnull[-1] == $pat + my ($args, $pat); + if ($args[-1] eq '...') { + $args = scalar @args; + $pat = $args - 1; + $args = $prefix . $args; + } + else { + # don't check args, and guess which arg is the pattern + # (one of 'fmt', 'pat', 'f'), + $args = 0; + my @fmts = grep $args[$_] =~ /\b(f|pat|fmt)$/, 0..$#args; + if (@fmts != 1) { + die "embed.pl: '$plain_func': can't determine pattern arg\n"; + } + $pat = $fmts[0] + 1; + } + my $macro = grep($_ == $pat, @nonnull) ? '__attribute__format__' : '__attribute__format__null_ok__'; - push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro, - $prefix, $pat, $prefix, $args; + if ($plain_func =~ /strftime/) { + push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix; + } + else { + push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro, + $prefix, $pat, $args; + } } - if ( @nonnull ) { - my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull; - push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos; + elsif ((grep { $_ eq '...' } @args) && $flags !~ /F/) { + die_at_end "$plain_func: Function with '...' arguments must have" + . " f or F flag"; } if ( @attrs ) { $ret .= "\n"; @@ -370,73 +254,50 @@ sub walk_table (&@) { } $ret .= ";"; $ret = "/* $ret */" if $commented_out; - if (@names_of_nn) { - $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t" - . join '; ', map "assert($_)", @names_of_nn; - } + + $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E" + if $args_assert_line || @names_of_nn; + $ret .= "\t\\\n\t" . join '; ', map "assert($_)", @names_of_nn + if @names_of_nn; + + $ret = "#ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#endif" if $static_inline; + $ret = "#ifndef NO_MATHOMS\n$ret\n#endif" if $binarycompat; $ret .= @attrs ? "\n\n" : "\n"; print $pr $ret; } - print $pr "END_EXTERN_C\n/* ex: set ro: */\n"; - - safer_close($pr); - rename_if_different('proto.h-new', 'proto.h'); -} + print $pr <<'EOF'; +#ifdef PERL_CORE +# include "pp_proto.h" +#endif +END_EXTERN_C +EOF -# generates global.sym (API export list) -{ - my %seen; - sub write_global_sym { - if (@_ > 1) { - my ($flags,$retval,$func,@args) = @_; - if ($flags =~ /[AX]/ && $flags !~ /[xm]/ - || $flags =~ /b/) { # public API, so export - # If a function is defined twice, for example before and after - # an #else, only export its name once. - return '' if $seen{$func}++; - $func = "Perl_$func" if $flags =~ /[pbX]/; - return "$func\n"; - } - } - return ''; - } + read_only_bottom_close_and_rename($pr) if ! $error_count; } -warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; -walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n"); +die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; -sub readvars(\%$$@) { - my ($syms, $file,$pre,$keep_pre) = @_; +sub readvars { + my ($file, $pre) = @_; local (*FILE, $_); - open(FILE, "< $file") + my %seen; + open(FILE, '<', $file) or die "embed.pl: Can't open $file: $!\n"; while () { s/[ \t]*#.*//; # Delete comments. - if (/PERLVARA?I?S?C?\($pre(\w+)/) { - my $sym = $1; - $sym = $pre . $sym if $keep_pre; - warn "duplicate symbol $sym while processing $file line $.\n" - if exists $$syms{$sym}; - $$syms{$sym} = $pre || 1; + if (/PERLVARA?I?C?\($pre,\s*(\w+)/) { + die_at_end "duplicate symbol $1 while processing $file line $.\n" + if $seen{$1}++; } } close(FILE); + return sort keys %seen; } -my %intrp; -my %globvar; - -readvars %intrp, 'intrpvar.h','I'; -readvars %globvar, 'perlvars.h','G'; - -my $sym; - -sub undefine ($) { - my ($sym) = @_; - "#undef $sym\n"; -} +my @intrp = readvars 'intrpvar.h','I'; +my @globvar = readvars 'perlvars.h','G'; sub hide { my ($from, $to, $indent) = @_; @@ -445,26 +306,14 @@ sub hide { "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n"; } -sub bincompat_var ($$) { - my ($pfx, $sym) = @_; - my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX'); - undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))"); -} - sub multon ($$$) { my ($sym,$pre,$ptr) = @_; hide("PL_$sym", "($ptr$pre$sym)"); } -sub multoff ($$) { - my ($sym,$pre) = @_; - return hide("PL_$pre$sym", "PL_$sym"); -} - -my $em = safer_open('embed.h-new'); - -print $em do_not_edit ("embed.h"), <<'END'; +my $em = open_print_header('embed.h'); +print $em <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms @@ -494,22 +343,19 @@ sub embed_h { } my $ret = ""; my ($flags,$retval,$func,@args) = @$_; - unless ($flags =~ /[om]/) { + unless ($flags =~ /[omM]/) { my $args = scalar @args; - if ($flags =~ /n/) { - if ($flags =~ /s/) { - $ret = hide($func,"S_$func"); - } - elsif ($flags =~ /p/) { - $ret = hide($func,"Perl_$func"); - } + if ($flags =~ /T/) { + my $full_name = full_name($func, $flags); + next if $full_name eq $func; # Don't output a no-op. + $ret = hide($func, $full_name); } elsif ($args and $args[$args-1] =~ /\.\.\./) { if ($flags =~ /p/) { # we're out of luck for varargs functions under CPP # So we can only do these macros for no implicit context: $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n" - . hide($func,"Perl_$func") . "#endif\n"; + . hide($func, full_name($func, $flags)) . "#endif\n"; } } else { @@ -517,15 +363,19 @@ sub embed_h { $ret = "#define $func($alist)"; my $t = int(length($ret) / 8); $ret .= "\t" x ($t < 4 ? 4 - $t : 1); - if ($flags =~ /s/) { - $ret .= "S_$func(aTHX"; - } - elsif ($flags =~ /p/) { - $ret .= "Perl_$func(aTHX"; - } + $ret .= full_name($func, $flags) . "(aTHX"; $ret .= "_ " if $alist; - $ret .= $alist . ")\n"; + $ret .= $alist; + if ($flags =~ /W/) { + if ($alist) { + $ret .= " _aDEPTH"; + } else { + die "Can't use W without other args (currently)"; + } + } + $ret .= ")\n"; } + $ret = "#ifndef NO_MATHOMS\n$ret#endif\n" if $flags =~ /b/; } $lines .= $ret; } @@ -544,9 +394,9 @@ sub embed_h { print $em "#endif\n" if $guard; } -embed_h('', \@api); -embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', \@ext); -embed_h('#ifdef PERL_CORE', \@core); +embed_h('', $api); +embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', $ext); +embed_h('#ifdef PERL_CORE', $core); print $em <<'END'; @@ -572,17 +422,32 @@ print $em <<'END'; # define perl_atexit(a,b) call_atexit(a,b) END -walk_table { - my ($flags,$retval,$func,@args) = @_; - return unless $func; - return unless $flags =~ /O/; +foreach (@$embed) { + my ($flags, $retval, $func, @args) = @$_; + next unless $func; + next unless $flags =~ /O/; my $alist = join ",", @az[0..$#args]; my $ret = "# define perl_$func($alist)"; my $t = (length $ret) >> 3; $ret .= "\t" x ($t < 5 ? 5 - $t : 1); - "$ret$func($alist)\n"; -} $em; + print $em "$ret$func($alist)\n"; +} + +my @nocontext; +{ + my (%has_va, %has_nocontext); + foreach (@$embed) { + next unless @$_ > 1; + ++$has_va{$_->[2]} if $_->[-1] =~ /\.\.\./; + ++$has_nocontext{$1} if $_->[2] =~ /(.*)_nocontext/; + } + + @nocontext = sort grep { + $has_nocontext{$_} + && !/printf/ # Not clear to me why these are skipped but they are. + } keys %has_va; +} print $em <<'END'; @@ -594,9 +459,7 @@ print $em <<'END'; #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES) END -foreach (sort keys %has_va) { - next unless $has_nocontext{$_}; - next if /printf/; # Not clear to me why these are skipped but they are. +foreach (@nocontext) { print $em hide($_, "Perl_${_}_nocontext", " "); } @@ -609,25 +472,19 @@ print $em <<'END'; /* undefined symbols, point them back at the usual ones */ END -foreach (sort keys %has_va) { - next unless $has_nocontext{$_}; - next if /printf/; # Not clear to me why these are skipped but they are. +foreach (@nocontext) { print $em hide("Perl_${_}_nocontext", "Perl_$_", " "); } print $em <<'END'; #endif - -/* ex: set ro: */ END -safer_close($em); -rename_if_different('embed.h-new', 'embed.h'); - -$em = safer_open('embedvar.h-new'); +read_only_bottom_close_and_rename($em) if ! $error_count; -print $em do_not_edit ("embedvar.h"), <<'END'; +$em = open_print_header('embedvar.h'); +print $em <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* @@ -654,64 +511,45 @@ print $em do_not_edit ("embedvar.h"), <<'END'; END -for $sym (sort keys %intrp) { - print $em multon($sym,'I','vTHX->'); -} - -print $em <<'END'; - -#else /* !MULTIPLICITY */ - -/* case 1 above */ - -END +my $sym; -for $sym (sort keys %intrp) { - print $em multoff($sym,'I'); +for $sym (@intrp) { + if ($sym eq 'sawampersand') { + print $em "#ifndef PL_sawampersand\n"; + } + print $em multon($sym,'I','vTHX->'); + if ($sym eq 'sawampersand') { + print $em "#endif\n"; + } } print $em <<'END'; -END - -print $em <<'END'; - #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) END -for $sym (sort keys %globvar) { +for $sym (@globvar) { + print $em "#ifdef OS2\n" if $sym eq 'sh_path'; + print $em "#ifdef __VMS\n" if $sym eq 'perllib_sep'; print $em multon($sym, 'G','my_vars->'); print $em multon("G$sym",'', 'my_vars->'); -} - -print $em <<'END'; - -#else /* !PERL_GLOBAL_STRUCT */ - -END - -for $sym (sort keys %globvar) { - print $em multoff($sym,'G'); + print $em "#endif\n" if $sym eq 'sh_path'; + print $em "#endif\n" if $sym eq 'perllib_sep'; } print $em <<'END'; #endif /* PERL_GLOBAL_STRUCT */ - -/* ex: set ro: */ END -safer_close($em); -rename_if_different('embedvar.h-new', 'embedvar.h'); - -my $capi = safer_open('perlapi.c-new'); -my $capih = safer_open('perlapi.h-new'); +read_only_bottom_close_and_rename($em) if ! $error_count; -print $capih do_not_edit ("perlapi.h"), <<'EOT'; +my $capih = open_print_header('perlapi.h'); +print $capih <<'EOT'; /* declare accessor functions for Perl variables */ #ifndef __perlapi_h__ #define __perlapi_h__ @@ -724,14 +562,11 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#undef PERLVARISC -#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX); -#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \ - EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); -#define PERLVARI(v,t,i) PERLVAR(v,t) -#define PERLVARIC(v,t,i) PERLVAR(v, const t) -#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \ - EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); +#define PERLVAR(p,v,t) EXTERN_C t* Perl_##p##v##_ptr(pTHX); +#define PERLVARA(p,v,n,t) typedef t PL_##v##_t[n]; \ + EXTERN_C PL_##v##_t* Perl_##p##v##_ptr(pTHX); +#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) +#define PERLVARIC(p,v,t,i) PERLVAR(p,v, const t) #include "perlvars.h" @@ -739,7 +574,6 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#undef PERLVARISC END_EXTERN_C @@ -762,11 +596,10 @@ EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#define PERLVAR(v,t) (void*)Perl_##v##_ptr, -#define PERLVARA(v,n,t) PERLVAR(v,t) -#define PERLVARI(v,t,i) PERLVAR(v,t) -#define PERLVARIC(v,t,i) PERLVAR(v,t) -#define PERLVARISC(v,i) PERLVAR(v,char) +#define PERLVAR(p,v,t) (void*)Perl_##p##v##_ptr, +#define PERLVARA(p,v,n,t) PERLVAR(p,v,t) +#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) +#define PERLVARIC(p,v,t,i) PERLVAR(p,v,t) /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one * cannot cast between void pointers and function pointers without @@ -791,7 +624,6 @@ EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#undef PERLVARISC }; #endif /* DOINIT */ @@ -803,8 +635,9 @@ END_EXTERN_C EOT -foreach $sym (sort keys %globvar) { - print $capih bincompat_var('G',$sym); +foreach $sym (@globvar) { + print $capih + "#undef PL_$sym\n" . hide("PL_$sym", "(*Perl_G${sym}_ptr(NULL))"); } print $capih <<'EOT'; @@ -813,14 +646,23 @@ print $capih <<'EOT'; #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ #endif /* __perlapi_h__ */ - -/* ex: set ro: */ EOT -safer_close($capih); -rename_if_different('perlapi.h-new', 'perlapi.h'); -print $capi do_not_edit ("perlapi.c"), <<'EOT'; +read_only_bottom_close_and_rename($capih) if ! $error_count; + +my $capi = open_print_header('perlapi.c', <<'EOQ'); + * + * + * Up to the threshold of the door there mounted a flight of twenty-seven + * broad stairs, hewn by some unknown art of the same black stone. This + * was the only entrance to the tower; ... + * + * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"] + * + */ +EOQ +print $capi <<'EOT'; #include "EXTERN.h" #include "perl.h" #include "perlapi.h" @@ -831,37 +673,32 @@ print $capi do_not_edit ("perlapi.c"), <<'EOT'; START_EXTERN_C #undef PERLVARI -#define PERLVARI(v,t,i) PERLVAR(v,t) +#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) #undef PERLVAR #undef PERLVARA -#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ +#define PERLVAR(p,v,t) t* Perl_##p##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } -#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ +#define PERLVARA(p,v,n,t) PL_##v##_t* Perl_##p##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #undef PERLVARIC -#undef PERLVARISC -#define PERLVARIC(v,t,i) \ - const t* Perl_##v##_ptr(pTHX) \ +#define PERLVARIC(p,v,t,i) \ + const t* Perl_##p##v##_ptr(pTHX) \ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); } -#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#undef PERLVARISC END_EXTERN_C #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ - -/* ex: set ro: */ EOT -safer_close($capi); -rename_if_different('perlapi.c-new', 'perlapi.c'); +read_only_bottom_close_and_rename($capi) if ! $error_count; + +die "$error_count errors found" if $error_count; # ex: set ts=8 sts=4 sw=4 noet: