#
# embed.h
# embedvar.h
-# global.sym
# perlapi.c
# perlapi.h
# proto.h
# 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.
#
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;
#
# 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 = <<EOW;
- -*- buffer-read-only: t -*-
-
- $file
-
- Copyright (C) $years, by Larry Wall and others
-
- You may distribute under the terms of either the GNU General Public
- License or the Artistic License, as specified in the README file.
-
-!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-This file is built by embed.pl from data in embed.fnc, embed.pl,
-pp.sym, intrpvar.h, and perlvars.h.
-Any changes made here will be lost!
-
-Edit those files and run 'make regen_headers' to effect changes.
-
-EOW
-
- $warning .= <<EOW if $file eq 'perlapi.c';
-
-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"]
-
-
-EOW
-
- if ($file =~ m:\.[ch]$:) {
- $warning =~ s:^: * :gm;
- $warning =~ s: +$::gm;
- $warning =~ s: :/:;
- $warning =~ s:$:/:;
- }
- else {
- $warning =~ s:^:# :gm;
- $warning =~ s: +$::gm;
- }
- $warning;
-} # do_not_edit
-
-open IN, "embed.fnc" or die $!;
-
-my @embed;
-my (%has_va, %has_nocontext);
-
-while (<IN>) {
- chomp;
- next if /^:/;
- next if /^$/;
- while (s|\\$||) {
- $_ .= <IN>;
- 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 (<IN>) {
- 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 =~ /[Si]/;
+ 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 =~ / ( [^AabCDdEefGhiMmNnOoPpRrSsTUuWXx] ) /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 = ( ! $binarycompat && $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 flag is mutually exclusive from the i and p plags"
+ if $flags =~ /S/ && $flags =~ /([ip])/;
+ 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 =~ /([Si])/) {
+ my $type;
+ if ($never_returns) {
+ $type = $1 eq 'S' ? "PERL_STATIC_NO_RET" : "PERL_STATIC_INLINE_NO_RET";
+ }
+ else {
+ $type = $1 eq 'S' ? "STATIC" : "PERL_STATIC_INLINE";
+ }
+ $retval = "$type $retval";
+ die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/;
+ $static_inline = $type eq 'PERL_STATIC_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', 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/;
+
+ $func = full_name($plain_func, $flags);
+ $ret = "";
+ $ret .= "$retval\t$func(";
if ( $has_context ) {
$ret .= @args ? "pTHX_ " : "pTHX";
}
$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;
else {
$ret .= "void" if !$has_context;
}
+ $ret .= " _pDEPTH" if $has_depth;
$ret .= ")";
my @attrs;
if ( $flags =~ /r/ ) {
}
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 ( @nonnull ) {
- my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
- push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+ 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 ( @attrs ) {
$ret .= "\n";
}
$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 (<FILE>) {
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) = @_;
"#${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
}
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 {
$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;
}
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';
# 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';
#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", " ");
}
/* 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.) */
/*
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__
#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"
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
END_EXTERN_C
#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
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
};
#endif /* DOINIT */
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';
#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"
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:
https://perl5.git.perl.org / perl5.git / blobdiff