X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=c917dfba092a69bc990a8830ed31ed7688d2b6b1;hb=c74ace89800a81a764294e9f6eacc04bbed5a568;hp=19609d4c8356bf1e9ee74a5e0808adedd7dbc5fe;hpb=06492da604676b8820ba5623ac813ceec4f48731;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/embed.pl b/embed.pl
index 19609d4..c917dfb 100755
--- a/embed.pl
+++ b/embed.pl
@@ -5,7 +5,7 @@ require 5.003;	# keep this compatible, an old perl is all we may have before
 
 BEGIN {
     # Get function prototypes
-    require 'regen.pl';
+    require 'regen_lib.pl';
 }
 
 #
@@ -18,11 +18,17 @@ BEGIN {
 sub do_not_edit ($)
 {
     my $file = shift;
+
+    my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
+
+    $years =~ s/1999,/1999,\n  / if length $years > 40;
+
     my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
 
    $file
 
-   Copyright (c) 1997-2002, Larry Wall
+   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.
@@ -36,6 +42,15 @@ 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.
+
+
+EOW
+
     if ($file =~ m:\.[ch]$:) {
 	$warning =~ s:^: * :gm;
 	$warning =~ s: +$::gm;
@@ -65,8 +80,9 @@ sub walk_table (&@) {
 	$F = $filename;
     }
     else {
-	safer_unlink $filename;
+	safer_unlink $filename if $filename ne '/dev/null';
 	open F, ">$filename" or die "Can't open $filename: $!";
+	binmode F;
 	$F = \*F;
     }
     print $F $leader if $leader;
@@ -78,6 +94,7 @@ sub walk_table (&@) {
 	    $_ .= <IN>;
 	    chomp;
 	}
+	s/\s+$//;
 	my @args;
 	if (/^\s*(#|$)/) {
 	    @args = $_;
@@ -85,8 +102,8 @@ sub walk_table (&@) {
 	else {
 	    @args = split /\s*\|\s*/, $_;
 	}
-        my @outs = &{$function}(@args);
-        print $F @outs; # $function->(@args) is not 5.003
+	my @outs = &{$function}(@args);
+	print $F @outs; # $function->(@args) is not 5.003
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
@@ -97,14 +114,14 @@ sub walk_table (&@) {
 sub munge_c_files () {
     my $functions = {};
     unless (@ARGV) {
-        warn "\@ARGV empty, nothing to do\n";
+	warn "\@ARGV empty, nothing to do\n";
 	return;
     }
     walk_table {
 	if (@_ > 1) {
 	    $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
 	}
-    } '/dev/null', '';
+    } '/dev/null', '', '';
     local $^I = '.bak';
     while (<>) {
 #	if (/^#\s*include\s+"perl.h"/) {
@@ -156,6 +173,8 @@ sub write_protos {
     }
     else {
 	my ($flags,$retval,$func,@args) = @_;
+	my @nonnull;
+	my $has_context = ( $flags !~ /n/ );
 	$ret .= '/* ' if $flags =~ /m/;
 	if ($flags =~ /s/) {
 	    $retval = "STATIC $retval";
@@ -168,29 +187,52 @@ sub write_protos {
 	    }
 	}
 	$ret .= "$retval\t$func(";
-	unless ($flags =~ /n/) {
-	    $ret .= "pTHX";
-	    $ret .= "_ " if @args;
+	if ( $has_context ) {
+	    $ret .= @args ? "pTHX_ " : "pTHX";
 	}
 	if (@args) {
+	    my $n;
+	    for my $arg ( @args ) {
+		++$n;
+		push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
+	    }
 	    $ret .= join ", ", @args;
 	}
 	else {
-	    $ret .= "void" if $flags =~ /n/;
+	    $ret .= "void" if !$has_context;
 	}
 	$ret .= ")";
-	$ret .= " __attribute__((noreturn))" if $flags =~ /r/;
+	my @attrs;
+	if ( $flags =~ /r/ ) {
+	    push @attrs, "__attribute__noreturn__";
+	}
+	if ( $flags =~ /a/ ) {
+	    push @attrs, "__attribute__malloc__";
+	    $flags .= "R"; # All allocing must check return value
+	}
+	if ( $flags =~ /R/ ) {
+	    push @attrs, "__attribute__warn_unused_result__";
+	}
+	if ( $flags =~ /P/ ) {
+	    push @attrs, "__attribute__pure__";
+	}
 	if( $flags =~ /f/ ) {
-	    my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
+	    my $prefix = $has_context ? 'pTHX_' : '';
 	    my $args = scalar @args;
-	    $ret .= "\n#ifdef CHECK_FORMAT\n";
-	    $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
+	    push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
 				    $prefix, $args - 1, $prefix, $args;
-	    $ret .= "\n#endif\n";
+	}
+	if ( @nonnull ) {
+	    my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
+	    push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+	}
+	if ( @attrs ) {
+	    $ret .= "\n";
+	    $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
 	}
 	$ret .= ";";
 	$ret .= ' */' if $flags =~ /m/;
-	$ret .= "\n";
+	$ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
 }
@@ -200,28 +242,29 @@ sub write_global_sym {
     my $ret = "";
     if (@_ > 1) {
 	my ($flags,$retval,$func,@args) = @_;
-	if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
-	    $func = "Perl_$func" if $flags =~ /p/;
+	if ($flags =~ /[AX]/ && $flags !~ /[xm]/
+	    || $flags =~ /b/) { # public API, so export
+	    $func = "Perl_$func" if $flags =~ /[pbX]/;
 	    $ret = "$func\n";
 	}
     }
     $ret;
 }
 
-walk_table(\&write_protos,     "proto.h", undef);
-walk_table(\&write_global_sym, "global.sym", undef);
+walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
+walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
 
 # XXX others that may need adding
 #       warnhook
 #       hints
 #       copline
 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
-                 curcop compiling
-                 tainting tainted stack_base stack_sp sv_arenaroot
+		 curcop compiling
+		 tainting tainted stack_base stack_sp sv_arenaroot
 		 no_modify
-                 curstash DBsub DBsingle DBassertion debstash
-                 rsfp
-                 stdingv
+		 curstash DBsub DBsingle DBassertion debstash
+		 rsfp
+		 stdingv
 		 defgv
 		 errgv
 		 rsfp_filters
@@ -259,7 +302,7 @@ sub readvars(\%$$@) {
 	or die "embed.pl: Can't open $file: $!\n";
     while (<FILE>) {
 	s/[ \t]*#.*//;		# Delete comments.
-	if (/PERLVARA?I?C?\($pre(\w+)/) {
+	if (/PERLVARA?I?S?C?\($pre(\w+)/) {
 	    my $sym = $1;
 	    $sym = $pre . $sym if $keep_pre;
 	    warn "duplicate symbol $sym while processing $file\n"
@@ -311,15 +354,17 @@ sub multoff ($$) {
 
 safer_unlink 'embed.h';
 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
+binmode EM;
 
 print EM do_not_edit ("embed.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
-/* NO_EMBED is no longer supported. i.e. EMBED is always active--
- * but you can define PERL_HIDE_SHORT_NAMES to achieve the same. */
+/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
+ * (like warn instead of Perl_warn) for the API are not defined.
+ * Not defining the short forms is a good thing for cleaner embedding. */
 
-#ifndef PERL_HIDE_SHORT_NAMES
+#ifndef PERL_NO_SHORT_NAMES
 
 /* Hide global symbols */
 
@@ -327,8 +372,19 @@ print EM do_not_edit ("embed.h"), <<'END';
 
 END
 
+# Try to elimiate lots of repeated
+# #ifdef PERL_CORE
+# foo
+# #endif
+# #ifdef PERL_CORE
+# bar
+# #endif
+# by tracking state and merging foo and bar into one block.
+my $ifdef_state = '';
+
 walk_table {
     my $ret = "";
+    my $new_ifdef_state = '';
     if (@_ == 1) {
 	my $arg = shift;
 	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
@@ -343,17 +399,33 @@ walk_table {
 		$ret .= hide($func,"Perl_$func");
 	    }
 	}
-         unless ($flags =~ /A/) {
+	if ($ret ne '' && $flags !~ /A/) {
 	    if ($flags =~ /E/) {
-		$ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
-	    } else {
-		$ret = "#ifdef PERL_CORE\n$ret#endif\n";
+		$new_ifdef_state
+		    = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+	    }
+	    else {
+		$new_ifdef_state = "#ifdef PERL_CORE\n";
+	    }
+
+	    if ($new_ifdef_state ne $ifdef_state) {
+		$ret = $new_ifdef_state . $ret;
 	    }
         }
     }
+    if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+	# Close the old one ahead of opening the new one.
+	$ret = "#endif\n$ret";
+    }
+    # Remember the new state.
+    $ifdef_state = $new_ifdef_state;
     $ret;
 } \*EM, "";
 
+if ($ifdef_state) {
+    print EM "#endif\n";
+}
+
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     print EM hide($sym, "Perl_$sym");
@@ -367,8 +439,10 @@ END
 
 my @az = ('a'..'z');
 
+$ifdef_state = '';
 walk_table {
     my $ret = "";
+    my $new_ifdef_state = '';
     if (@_ == 1) {
 	my $arg = shift;
 	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
@@ -403,17 +477,33 @@ walk_table {
 		$ret .= $alist . ")\n";
 	    }
 	}
-         unless ($flags =~ /A/) {
+	unless ($flags =~ /A/) {
 	    if ($flags =~ /E/) {
-		$ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
-	    } else {
-		$ret = "#ifdef PERL_CORE\n$ret#endif\n";
+		$new_ifdef_state
+		    = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+	    }
+	    else {
+		$new_ifdef_state = "#ifdef PERL_CORE\n";
+	    }
+
+	    if ($new_ifdef_state ne $ifdef_state) {
+		$ret = $new_ifdef_state . $ret;
 	    }
         }
     }
+    if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+	# Close the old one ahead of opening the new one.
+	$ret = "#endif\n$ret";
+    }
+    # Remember the new state.
+    $ifdef_state = $new_ifdef_state;
     $ret;
 } \*EM, "";
 
+if ($ifdef_state) {
+    print EM "#endif\n";
+}
+
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
@@ -431,7 +521,7 @@ print EM <<'END';
 
 #endif	/* PERL_IMPLICIT_CONTEXT */
 
-#endif	/* #ifndef PERL_HIDE_SHORT_NAMES */
+#endif	/* #ifndef PERL_NO_SHORT_NAMES */
 
 END
 
@@ -477,7 +567,7 @@ print EM <<'END';
    an extra argument but grab the context pointer using the macro
    dTHX.
  */
-#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_HIDE_SHORT_NAMES)
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 #  define croak				Perl_croak_nocontext
 #  define deb				Perl_deb_nocontext
 #  define die				Perl_die_nocontext
@@ -512,6 +602,7 @@ print EM <<'END';
 #  define Perl_sv_setpvf_mg_nocontext	Perl_sv_setpvf_mg
 #endif
 
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -519,6 +610,7 @@ close(EM) or die "Error closing EM: $!";
 safer_unlink 'embedvar.h';
 open(EM, '> embedvar.h')
     or die "Can't create embedvar.h: $!\n";
+binmode EM;
 
 print EM do_not_edit ("embedvar.h"), <<'END';
 
@@ -591,7 +683,8 @@ print EM <<'END';
 END
 
 for $sym (sort keys %globvar) {
-    print EM multon($sym,'G','PL_Vars.');
+    print EM multon($sym,   'G','my_vars->');
+    print EM multon("G$sym",'', 'my_vars->');
 }
 
 print EM <<'END';
@@ -619,6 +712,8 @@ for $sym (sort @extvars) {
 print EM <<'END';
 
 #endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -626,7 +721,9 @@ close(EM) or die "Error closing EM: $!";
 safer_unlink 'perlapi.h';
 safer_unlink 'perlapi.c';
 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
+binmode CAPI;
 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
+binmode CAPIH;
 
 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
 
@@ -642,11 +739,14 @@ 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);
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -656,6 +756,16 @@ START_EXTERN_C
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
+EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
+EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
+#define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
+#define Perl_check_ptr       Perl_Gcheck_ptr
+#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
+#endif
 
 END_EXTERN_C
 
@@ -671,9 +781,9 @@ END_EXTERN_C
 START_EXTERN_C
 
 #ifndef DOINIT
-EXT void *PL_force_link_funcs[];
+EXTCONST void * const PL_force_link_funcs[];
 #else
-EXT void *PL_force_link_funcs[] = {
+EXTCONST void * const PL_force_link_funcs[] = {
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
@@ -682,6 +792,7 @@ EXT void *PL_force_link_funcs[] = {
 #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)
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -691,6 +802,7 @@ EXT void *PL_force_link_funcs[] = {
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
 };
 #endif	/* DOINIT */
 
@@ -721,6 +833,7 @@ print CAPIH <<'EOT';
 
 #endif /* __perlapi_h__ */
 
+/* ex: set ro: */
 EOT
 close CAPIH or die "Error closing CAPIH: $!";
 
@@ -739,14 +852,17 @@ START_EXTERN_C
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
 
 #define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
-			{ return &(aTHX->v); }
+			{ dVAR; return &(aTHX->v); }
 #define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
-			{ return &(aTHX->v); }
+			{ dVAR; return &(aTHX->v); }
 
 #define PERLVARI(v,t,i)	PERLVAR(v,t)
 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
+#define PERLVARISC(v,i)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
+			{ dVAR; return &(aTHX->v); }
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -754,22 +870,48 @@ START_EXTERN_C
 #undef PERLVAR
 #undef PERLVARA
 #define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
-			{ return &(PL_##v); }
+			{ dVAR; return &(PL_##v); }
 #define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
-			{ return &(PL_##v); }
+			{ dVAR; return &(PL_##v); }
 #undef PERLVARIC
-#define PERLVARIC(v,t,i)	const t* Perl_##v##_ptr(pTHX)		\
+#undef PERLVARISC
+#define PERLVARIC(v,t,i)	\
+			const t* Perl_##v##_ptr(pTHX)		\
 			{ return (const t *)&(PL_##v); }
+#define PERLVARISC(v,i)	PL_##v##_t* Perl_##v##_ptr(pTHX)	\
+			{ dVAR; return &(PL_##v); }
 #include "perlvars.h"
 
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+/* A few evil special cases.  Could probably macrofy this. */
+#undef PL_ppaddr
+#undef PL_check
+#undef PL_fold_locale
+Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
+    static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
+    return (Perl_ppaddr_t**)&ppaddr_ptr;
+}
+Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
+    static const Perl_check_t* check_ptr  = PL_check;
+    return (Perl_check_t**)&check_ptr;
+}
+unsigned char** Perl_Gfold_locale_ptr(pTHX) {
+    static const unsigned char* fold_locale_ptr = PL_fold_locale;
+    return (unsigned char**)&fold_locale_ptr;
+}
+#endif
 
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
+
+/* ex: set ro: */
 EOT
 
 close(CAPI) or die "Error closing CAPI: $!";