X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a3a88924926dbbb2266637650a9d6c86eb3d54a9..b289a0bd3e66981f9f724fb37f0f1aa6c8931ba0:/regen/embed.pl

diff --git a/regen/embed.pl b/regen/embed.pl
index 5be3744..f1b7449 100755
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -4,7 +4,6 @@
 #
 #    embed.h
 #    embedvar.h
-#    global.sym
 #    perlapi.c
 #    perlapi.h
 #    proto.h
@@ -27,7 +26,8 @@ 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
@@ -40,6 +40,15 @@ my $unflagged_pointers;
 # implicit interpreter context argument.
 #
 
+sub full_name ($$) { # Returns the function name with potentially the
+		     # prefixes 'S_' or 'Perl_'
+    my ($func, $flags) = @_;
+
+    return "Perl_$func" if $flags =~ /p/;
+    return "S_$func" if $flags =~ /[si]/;
+    return $func;
+}
+
 sub open_print_header {
     my ($file, $quote) = @_;
 
@@ -51,164 +60,7 @@ sub open_print_header {
 		      copyright => [1993 .. 2009], quote => $quote });
 }
 
-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;
-}
-
-open IN, 'regen/opcodes' or die $!;
-{
-    my %syms;
-
-    while (<IN>) {
-	chop;
-	next unless $_;
-	next if /^#/;
-	my (undef, undef, $check) = split /\t+/, $_;
-	++$syms{$check};
-    }
-
-    foreach (keys %syms) {
-	# These are all indirectly referenced by globals.c.
-	push @embed, ['pR', 'OP *', $_, 'NN OP *o'];
-    }
-}
-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.
-    # Output structure is actually the same as input structure - an
-    # (ordered) list of array references, where the elements in the reference
-    # determine what it is - a reference to a 1-element array is a
-    # pre-processor directive, a reference to 2+ element array is a function.
-
-    # Records the current pre-processor state:
-    my @state;
-    # Nested structure to group functions by the pre-processor conditions that
-    # control when they are compiled:
-    my %groups;
-
-    sub current_group {
-	my $group = \%groups;
-	# Nested #if blocks are effectively &&ed together
-	# For embed.fnc, ordering within the && isn't relevant, so we can
-	# sort them to try to group more functions together.
-	foreach (sort @state) {
-	    $group->{$_} ||= {};
-	    $group = $group->{$_};
-	}
-	return $group->{''} ||= [];
-    }
-
-    my $current = current_group();
-
-    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 = current_group();
-    }
-
-    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, '');
-}
-
-# walk table providing an array of components in each line to
-# subroutine, printing the result
-sub walk_table (&@) {
-    my ($function, $filename) = @_;
-    my $F;
-    if (ref $filename) {	# filehandle
-	$F = $filename;
-    }
-    else {
-	$F = open_print_header($filename);
-    }
-    foreach (@embed) {
-	my @outs = &{$function}(@$_);
-	# $function->(@args) is not 5.003
-	print $F @outs;
-    }
-    unless (ref $filename) {
-	read_only_bottom_close_and_rename($F);
-    }
-}
+my ($embed, $core, $ext, $api) = setup_embed();
 
 # generate proto.h
 {
@@ -216,23 +68,33 @@ sub walk_table (&@) {
     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 =~ / ( [^AabDdEfiMmnOoPpRrsUWXx] ) /x) {
+	    warn "flag $1 is not legal (for function $plain_func)";
+	}
 	my @nonnull;
+        my $has_depth = ( $flags =~ /W/ );
 	my $has_context = ( $flags !~ /n/ );
 	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;
 
+	if (! $can_ignore && $retval eq 'void') {
+	    warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
+	}
+
+	warn "$plain_func: s flag is mutually exclusive from the i and p plags"
+					    if $flags =~ /s/ && $flags =~ /[ip]/;
 	my $splint_flags = "";
 	if ( $SPLINT && !$commented_out ) {
 	    $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
@@ -242,21 +104,27 @@ sub walk_table (&@) {
 	}
 
 	if ($flags =~ /([si])/) {
-	    my $type = ($1 eq 's') ? "STATIC" : "PERL_STATIC_INLINE";
-	    warn "$func: i and s flags are mutually exclusive"
-					    if $flags =~ /s/ && $flags =~ /i/;
+	    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 $splint_flags$retval";
-	    $func = "S_$plain_func";
 	}
 	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 $splint_flags$retval";
+	    }
+	    else {
+		$retval = "PERL_CALLCONV $splint_flags$retval";
 	    }
 	}
-	$ret = "$retval\t$func(";
+	$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";
 	}
@@ -294,6 +162,7 @@ sub walk_table (&@) {
 	else {
 	    $ret .= "void" if !$has_context;
 	}
+        $ret .= " _pDEPTH" if $has_depth;
 	$ret .= ")";
 	my @attrs;
 	if ( $flags =~ /r/ ) {
@@ -313,17 +182,32 @@ sub walk_table (&@) {
 	}
 	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";
@@ -335,6 +219,7 @@ sub walk_table (&@) {
 	    $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 .= @attrs ? "\n\n" : "\n";
 
 	print $pr $ret;
@@ -350,27 +235,7 @@ EOF
     read_only_bottom_close_and_rename($pr);
 }
 
-# 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 '';
-  }
-}
-
 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
-walk_table(\&write_global_sym, "global.sym");
 
 sub readvars {
     my ($file, $pre) = @_;
@@ -439,19 +304,16 @@ sub embed_h {
 	unless ($flags =~ /[om]/) {
 	    my $args = scalar @args;
 	    if ($flags =~ /n/) {
-		if ($flags =~ /s/) {
-		    $ret = hide($func,"S_$func");
-		}
-		elsif ($flags =~ /p/) {
-		    $ret = hide($func,"Perl_$func");
-		}
+		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 {
@@ -459,15 +321,19 @@ sub embed_h {
 		$ret = "#define $func($alist)";
 		my $t = int(length($ret) / 8);
 		$ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
-		if ($flags =~ /[si]/) {
-		    $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;
     }
@@ -486,9 +352,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';
 
@@ -514,17 +380,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';
 
@@ -536,9 +417,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", "  ");
 }
 
@@ -551,9 +430,7 @@ 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_$_", "  ");
 }
 
@@ -595,7 +472,13 @@ END
 my $sym;
 
 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';
@@ -608,9 +491,11 @@ END
 
 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';