X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=c917dfba092a69bc990a8830ed31ed7688d2b6b1;hb=4325052d2625a06294068527f0d65e6f637a59ee;hp=fee23631dcb0931c67c096c2fa0fb9604f7e349a;hpb=346f75ffc624859cdc8927b1e206026c5a850b7c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/embed.pl b/embed.pl index fee2363..c917dfb 100755 --- a/embed.pl +++ b/embed.pl @@ -3,6 +3,11 @@ require 5.003; # keep this compatible, an old perl is all we may have before # we build the new one +BEGIN { + # Get function prototypes + require 'regen_lib.pl'; +} + # # See database of global and static function prototypes in embed.fnc # This is used to generate prototype headers under various configurations, @@ -10,6 +15,55 @@ require 5.003; # keep this compatible, an old perl is all we may have before # 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'; + + $years =~ s/1999,/1999,\n / if length $years > 40; + + my $warning = <$filename" or die "Can't open $filename: $!"; + binmode F; $F = \*F; } print $F $leader if $leader; @@ -38,6 +94,7 @@ sub walk_table (&@) { $_ .= ; chomp; } + s/\s+$//; my @args; if (/^\s*(#|$)/) { @args = $_; @@ -45,24 +102,26 @@ 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; - close $F unless ref $filename; + unless (ref $filename) { + close $F or die "Error closing $filename: $!"; + } } 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"/) { @@ -114,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"; @@ -126,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; } @@ -158,58 +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', <<'EOT'); -/* - * proto.h - * - * Copyright (c) 1997-2002, Larry Wall - * - * 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 autogenerated from data in embed.pl. Edit that file - * and run 'make regen_headers' to effect changes. - */ - -EOT - -walk_table(\&write_global_sym, 'global.sym', <<'EOT'); -# -# global.sym -# -# Copyright (c) 1997-2002, Larry Wall -# -# 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 autogenerated from data in embed.pl. Edit that file -# and run 'make regen_headers' to effect changes. -# - -EOT +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 debstash - rsfp - stdingv + curstash DBsub DBsingle DBassertion debstash + rsfp + stdingv defgv errgv rsfp_filters @@ -247,7 +302,7 @@ sub readvars(\%$$@) { or die "embed.pl: Can't open $file: $!\n"; while () { 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" @@ -297,26 +352,19 @@ sub multoff ($$) { return hide("PL_$pre$sym", "PL_$sym"); } -unlink 'embed.h'; +safer_unlink 'embed.h'; open(EM, '> embed.h') or die "Can't create embed.h: $!\n"; +binmode EM; -print EM <<'END'; -/* - * embed.h - * - * Copyright (c) 1997-2002, Larry Wall - * - * 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.pl, pp.sym, intrpvar.h, - * perlvars.h and thrdvar.h. Any changes made here will be lost! - */ +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. */ +/* 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_NO_SHORT_NAMES /* Hide global symbols */ @@ -324,8 +372,19 @@ print EM <<'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/; @@ -340,9 +399,32 @@ walk_table { $ret .= hide($func,"Perl_$func"); } } + if ($ret ne '' && $flags !~ /A/) { + if ($flags =~ /E/) { + $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; +} \*EM, ""; + +if ($ifdef_state) { + print EM "#endif\n"; +} for $sym (sort keys %ppsym) { $sym =~ s/^Perl_//; @@ -357,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/; @@ -393,9 +477,32 @@ walk_table { $ret .= $alist . ")\n"; } } + unless ($flags =~ /A/) { + if ($flags =~ /E/) { + $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; +} \*EM, ""; + +if ($ifdef_state) { + print EM "#endif\n"; +} for $sym (sort keys %ppsym) { $sym =~ s/^Perl_//; @@ -414,6 +521,8 @@ print EM <<'END'; #endif /* PERL_IMPLICIT_CONTEXT */ +#endif /* #ifndef PERL_NO_SHORT_NAMES */ + END print EM <<'END'; @@ -458,7 +567,7 @@ print EM <<'END'; an extra argument but grab the context pointer using the macro dTHX. */ -#if defined(PERL_IMPLICIT_CONTEXT) +#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 @@ -493,48 +602,35 @@ print EM <<'END'; # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg #endif +/* ex: set ro: */ END -close(EM); +close(EM) or die "Error closing EM: $!"; -unlink 'embedvar.h'; +safer_unlink 'embedvar.h'; open(EM, '> embedvar.h') or die "Can't create embedvar.h: $!\n"; +binmode EM; -print EM <<'END'; -/* - * embedvar.h - * - * Copyright (c) 1997-2002, Larry Wall - * - * 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.pl, pp.sym, intrpvar.h, - * perlvars.h and thrdvar.h. Any changes made here will be lost! - */ +print EM do_not_edit ("embedvar.h"), <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* - The following combinations of MULTIPLICITY, USE_5005THREADS - and PERL_IMPLICIT_CONTEXT are supported: + The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT + are supported: 1) none 2) MULTIPLICITY # supported for compatibility 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT - 4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT - 5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT All other combinations of these flags are errors. - #3, #4, #5, and #6 are supported directly, while #2 is a special + only #3 is supported directly, while #2 is a special case of #3 (supported by redefining vTHX appropriately). */ #if defined(MULTIPLICITY) -/* cases 2, 3 and 5 above */ +/* cases 2 and 3 above */ # if defined(PERL_IMPLICIT_CONTEXT) # define vTHX aTHX @@ -550,18 +646,6 @@ for $sym (sort keys %thread) { print EM <<'END'; -# if defined(USE_5005THREADS) -/* case 5 above */ - -END - -for $sym (sort keys %intrp) { - print EM multon($sym,'I','PERL_GET_INTERP->'); -} - -print EM <<'END'; - -# else /* !USE_5005THREADS */ /* cases 2 and 3 above */ END @@ -572,11 +656,9 @@ for $sym (sort keys %intrp) { print EM <<'END'; -# endif /* USE_5005THREADS */ - #else /* !MULTIPLICITY */ -/* cases 1 and 4 above */ +/* case 1 above */ END @@ -586,20 +668,6 @@ for $sym (sort keys %intrp) { print EM <<'END'; -# if defined(USE_5005THREADS) -/* case 4 above */ - -END - -for $sym (sort keys %thread) { - print EM multon($sym,'T','aTHX->'); -} - -print EM <<'END'; - -# else /* !USE_5005THREADS */ -/* case 1 above */ - END for $sym (sort keys %thread) { @@ -608,7 +676,6 @@ for $sym (sort keys %thread) { print EM <<'END'; -# endif /* USE_5005THREADS */ #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) @@ -616,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'; @@ -644,29 +712,20 @@ for $sym (sort @extvars) { print EM <<'END'; #endif /* PERL_POLLUTE */ + +/* ex: set ro: */ END -close(EM); +close(EM) or die "Error closing EM: $!"; -unlink 'perlapi.h'; -unlink 'perlapi.c'; +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 <<'EOT'; -/* - * perlapi.h - * - * Copyright (c) 1997-2002, Larry Wall - * - * 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.pl, pp.sym, intrpvar.h, - * perlvars.h and thrdvar.h. Any changes made here will be lost! - */ +print CAPIH do_not_edit ("perlapi.h"), <<'EOT'; /* declare accessor functions for Perl variables */ #ifndef __perlapi_h__ @@ -680,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" @@ -694,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 @@ -709,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 @@ -720,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" @@ -729,6 +802,7 @@ EXT void *PL_force_link_funcs[] = { #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC }; #endif /* DOINIT */ @@ -759,23 +833,11 @@ print CAPIH <<'EOT'; #endif /* __perlapi_h__ */ +/* ex: set ro: */ EOT -close CAPIH; +close CAPIH or die "Error closing CAPIH: $!"; -print CAPI <<'EOT'; -/* - * perlapi.c - * - * Copyright (c) 1997-2002, Larry Wall - * - * 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.pl, pp.sym, intrpvar.h, - * perlvars.h and thrdvar.h. Any changes made here will be lost! - */ +print CAPI do_not_edit ("perlapi.c"), <<'EOT'; #include "EXTERN.h" #include "perl.h" @@ -790,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" @@ -805,25 +870,51 @@ 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); +close(CAPI) or die "Error closing CAPI: $!"; # functions that take va_list* for implementing vararg functions # NOTE: makedef.pl must be updated if you add symbols to %vfuncs