#!/usr/bin/perl -w
-#
+#
# Regenerate (overwriting only if changed):
#
# embed.h
BEGIN {
# Get function prototypes
- require 'regen/regen_lib.pl';
- require 'regen/embed_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.
#
+my $error_count = 0;
+sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't
+ # succeed.
+ warn shift;
+ $error_count++;
+}
+
sub full_name ($$) { # Returns the function name with potentially the
# prefixes 'S_' or 'Perl_'
my ($func, $flags) = @_;
- return "S_$func" if $flags =~ /[si]/;
return "Perl_$func" if $flags =~ /p/;
+ return "S_$func" if $flags =~ /[SIi]/;
return $func;
}
}
my ($flags,$retval,$plain_func,@args) = @$_;
- if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUXx] ) /x) {
- warn "flag $1 is not legal (for function $plain_func)";
+ 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 $binarycompat = ( $flags =~ /b/ );
- my $commented_out = ( ! $binarycompat && $flags =~ /m/ );
+ 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;
warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
}
- my $scope_type_flag_count = 0;
- $scope_type_flag_count++ if $flags =~ /s/;
- $scope_type_flag_count++ if $flags =~ /i/;
- $scope_type_flag_count++ if $flags =~ /p/;
- warn "$plain_func: i, p, and s flags are all mutually exclusive"
- if $scope_type_flag_count > 1;
- my $splint_flags = "";
- if ( $SPLINT && !$commented_out ) {
- $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
- if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
- $retval .= " /*\@alt void\@*/";
- }
- }
+ 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/;
- if ($flags =~ /([si])/) {
+ my $static_inline = 0;
+ if ($flags =~ /([SIi])/) {
my $type;
if ($never_returns) {
- $type = $1 eq 's' ? "PERL_STATIC_NO_RET" : "PERL_STATIC_INLINE_NO_RET";
+ $type = {
+ 'S' => 'PERL_STATIC_NO_RET',
+ 'i' => 'PERL_STATIC_INLINE_NO_RET',
+ 'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET'
+ }->{$1};
}
else {
- $type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE";
+ $type = {
+ 'S' => 'STATIC',
+ 'i' => 'PERL_STATIC_INLINE',
+ 'I' => 'PERL_STATIC_FORCE_INLINE'
+ }->{$1};
}
- $retval = "$type $splint_flags$retval";
+ $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 {
if ($never_returns) {
- $retval = "PERL_CALLCONV_NO_RET $splint_flags$retval";
+ $retval = "PERL_CALLCONV_NO_RET $retval";
}
else {
- $retval = "PERL_CALLCONV $splint_flags$retval";
+ $retval = "PERL_CALLCONV $retval";
}
}
+
+ 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 .= "#ifndef NO_MATHOMS\n" if $binarycompat;
$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;
$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 =~ /P/ ) {
push @attrs, "__attribute__pure__";
}
+ if ( $flags =~ /I/ ) {
+ push @attrs, "__attribute__always_inline__";
+ }
if( $flags =~ /f/ ) {
my $prefix = $has_context ? 'pTHX_' : '';
my ($args, $pat);
$prefix, $pat, $args;
}
}
+ elsif ((grep { $_ eq '...' } @args) && $flags !~ /F/) {
+ die_at_end "$plain_func: Function with '...' arguments must have"
+ . " f or F flag";
+ }
if ( @attrs ) {
$ret .= "\n";
$ret .= join( "\n", map { "\t\t\t$_" } @attrs );
}
$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#endif" if $binarycompat;
+
+ $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;
END_EXTERN_C
EOF
- read_only_bottom_close_and_rename($pr);
+ read_only_bottom_close_and_rename($pr) if ! $error_count;
}
-warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
+die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
sub readvars {
my ($file, $pre) = @_;
local (*FILE, $_);
my %seen;
- open(FILE, "< $file")
+ open(FILE, '<', $file)
or die "embed.pl: Can't open $file: $!\n";
while (<FILE>) {
s/[ \t]*#.*//; # Delete comments.
if (/PERLVARA?I?C?\($pre,\s*(\w+)/) {
- warn "duplicate symbol $1 while processing $file line $.\n"
+ die_at_end "duplicate symbol $1 while processing $file line $.\n"
if $seen{$1}++;
}
}
}
my $ret = "";
my ($flags,$retval,$func,@args) = @$_;
- unless ($flags =~ /[om]/) {
+ unless ($flags =~ /[omM]/) {
my $args = scalar @args;
- if ($flags =~ /n/) {
+ 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);
$ret .= "\t" x ($t < 4 ? 4 - $t : 1);
$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/;
}
#endif
END
-read_only_bottom_close_and_rename($em);
+read_only_bottom_close_and_rename($em) if ! $error_count;
$em = open_print_header('embedvar.h');
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 "#endif\n" if $sym eq 'sh_path';
+ print $em "#endif\n" if $sym eq 'perllib_sep';
}
print $em <<'END';
#endif /* PERL_GLOBAL_STRUCT */
END
-read_only_bottom_close_and_rename($em);
+read_only_bottom_close_and_rename($em) if ! $error_count;
my $capih = open_print_header('perlapi.h');
#endif /* __perlapi_h__ */
EOT
-read_only_bottom_close_and_rename($capih);
+read_only_bottom_close_and_rename($capih) if ! $error_count;
my $capi = open_print_header('perlapi.c', <<'EOQ');
*
#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
EOT
-read_only_bottom_close_and_rename($capi);
+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