X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb1102fcca2230364ceadea29bd8e87ee51b15fa..454fb80f45fb0b01f1ab0b356c14e9c7a9ffbfec:/embed.pl?ds=sidebyside diff --git a/embed.pl b/embed.pl index 073cdf3..7d4dbc4 100755 --- a/embed.pl +++ b/embed.pl @@ -3,13 +3,71 @@ require 5.003; # keep this compatible, an old perl is all we may have before # we build the new one +use strict; + +BEGIN { + # Get function prototypes + require 'regen_lib.pl'; +} + +my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org + # -# See database of global and static function prototypes at the __END__. +# See database of global and static function prototypes in embed.fnc # This is used to generate prototype headers under various configurations, # export symbols lists for different platforms, and macros to provide an # 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'; + + $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 +98,7 @@ sub walk_table (&@) { $_ .= ; chomp; } + s/\s+$//; my @args; if (/^\s*(#|$)/) { @args = $_; @@ -45,46 +106,28 @@ 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"/) { -# my $file = uc $ARGV; -# $file =~ s/\./_/g; -# print "#define PERL_IN_$file\n"; -# } -# s{^(\w+)\s*\(} -# { -# my $f = $1; -# my $repl = "$f("; -# if (exists $functions->{$f}) { -# my $flags = $functions->{$f}[0]; -# $repl = "Perl_$repl" if $flags =~ /p/; -# unless ($flags =~ /n/) { -# $repl .= "pTHX"; -# $repl .= "_ " if @{$functions->{$f}} > 3; -# } -# warn("$ARGV:$.:$repl\n"); -# } -# $repl; -# }e; s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))} { my $repl = $1; @@ -114,102 +157,138 @@ sub write_protos { } else { my ($flags,$retval,$func,@args) = @_; - $ret .= '/* ' if $flags =~ /m/; + my @nonnull; + my $has_context = ( $flags !~ /n/ ); + my $never_returns = ( $flags =~ /r/ ); + my $commented_out = ( $flags =~ /m/ ); + my $is_malloc = ( $flags =~ /a/ ); + my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc; + + my $splint_flags = ""; + if ( $SPLINT && !$commented_out ) { + $splint_flags .= '/*@noreturn@*/ ' if $never_returns; + if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) { + $retval .= " /*\@alt void\@*/"; + } + } + if ($flags =~ /s/) { - $retval = "STATIC $retval"; + $retval = "STATIC $splint_flags$retval"; $func = "S_$func"; } else { - $retval = "PERL_CALLCONV $retval"; + $retval = "PERL_CALLCONV $splint_flags$retval"; if ($flags =~ /p/) { $func = "Perl_$func"; } } $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; + if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) { + warn "$func: $arg needs NN or NULLOK\n"; + our $unflagged_pointers; + ++$unflagged_pointers; + } + my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); + push( @nonnull, $n ) if $nn; + + my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect + + # Make sure each arg has at least a type and a var name. + # An arg of "int" is valid C, but want it to be "int foo". + my $temp_arg = $arg; + $temp_arg =~ s/\*//g; + $temp_arg =~ s/\s*\bstruct\b\s*/ /g; + if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+\w+/) ) { + warn "$func: $arg doesn't have a name\n"; + } + if ( $SPLINT && $nullok && !$commented_out ) { + $arg = '/*@null@*/ ' . $arg; + } + } $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 ( $is_malloc ) { + push @attrs, "__attribute__malloc__"; + } + if ( !$can_ignore ) { + 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 = "/* $ret */" if $commented_out; + $ret .= @attrs ? "\n\n" : "\n"; } $ret; } -# generates global.sym (API export list), and populates %global with global symbols -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/; - $ret = "$func\n"; - } - } - $ret; +# generates global.sym (API export list) +{ + my %seen; + sub write_global_sym { + my $ret = ""; + if (@_ > 1) { + my ($flags,$retval,$func,@args) = @_; + # If a function is defined twice, for example before and after an + # #else, only process the flags on the first instance for global.sym + return $ret if $seen{$func}++; + 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 +our $unflagged_pointers; +walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n"); +warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; +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 +326,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" @@ -260,6 +339,7 @@ sub readvars(\%$$@) { my %intrp; my %thread; +my %globvar; readvars %intrp, 'intrpvar.h','I'; readvars %thread, 'thrdvar.h','T'; @@ -297,62 +377,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. */ - -/* provide binary compatible (but inconsistent) names */ -#if defined(PERL_BINCOMPAT_5005) -# define Perl_call_atexit perl_atexit -# define Perl_eval_sv perl_eval_sv -# define Perl_eval_pv perl_eval_pv -# define Perl_call_argv perl_call_argv -# define Perl_call_method perl_call_method -# define Perl_call_pv perl_call_pv -# define Perl_call_sv perl_call_sv -# define Perl_get_av perl_get_av -# define Perl_get_cv perl_get_cv -# define Perl_get_hv perl_get_hv -# define Perl_get_sv perl_get_sv -# define Perl_init_i18nl10n perl_init_i18nl10n -# define Perl_init_i18nl14n perl_init_i18nl14n -# define Perl_new_collate perl_new_collate -# define Perl_new_ctype perl_new_ctype -# define Perl_new_numeric perl_new_numeric -# define Perl_require_pv perl_require_pv -# define Perl_safesyscalloc Perl_safecalloc -# define Perl_safesysfree Perl_safefree -# define Perl_safesysmalloc Perl_safemalloc -# define Perl_safesysrealloc Perl_saferealloc -# define Perl_set_numeric_local perl_set_numeric_local -# define Perl_set_numeric_standard perl_set_numeric_standard -/* malloc() pollution was the default in earlier versions, so enable - * it for bincompat; but not for systems that used to do prevent that, - * or when they ask for {HIDE,EMBED}MYMALLOC */ -# if !defined(EMBEDMYMALLOC) && !defined(HIDEMYMALLOC) -# if !defined(NeXT) && !defined(__NeXT) && !defined(__MACHTEN__) && \ - !defined(__QNX__) -# define PERL_POLLUTE_MALLOC -# endif -# endif -#endif +/* 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 */ @@ -360,8 +397,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/; @@ -376,9 +424,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_//; @@ -393,8 +464,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/; @@ -429,9 +502,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_//; @@ -450,6 +546,8 @@ print EM <<'END'; #endif /* PERL_IMPLICIT_CONTEXT */ +#endif /* #ifndef PERL_NO_SHORT_NAMES */ + END print EM <<'END'; @@ -460,10 +558,10 @@ print EM <<'END'; #if !defined(PERL_CORE) # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) -# define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr)) +# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) #endif -#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) && !defined(PERL_BINCOMPAT_5005) +#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) /* Compatibility for various misnamed functions. All functions in the API that begin with "perl_" (not "Perl_") take an explicit @@ -494,7 +592,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 @@ -529,48 +627,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 @@ -586,18 +671,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 @@ -608,11 +681,9 @@ for $sym (sort keys %intrp) { print EM <<'END'; -# endif /* USE_5005THREADS */ - #else /* !MULTIPLICITY */ -/* cases 1 and 4 above */ +/* case 1 above */ END @@ -622,20 +693,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) { @@ -644,7 +701,6 @@ for $sym (sort keys %thread) { print EM <<'END'; -# endif /* USE_5005THREADS */ #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) @@ -652,7 +708,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'; @@ -680,29 +737,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__ @@ -716,11 +764,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" @@ -730,6 +781,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 @@ -745,9 +806,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 @@ -756,15 +817,34 @@ 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) + +/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one + * cannot cast between void pointers and function pointers without + * info level warnings. The PL_force_link_funcs[] would cause a few + * hundred of those warnings. In code one can circumnavigate this by using + * unions that overlay the different pointers, but in declarations one + * cannot use this trick. Therefore we just disable the warning here + * for the duration of the PL_force_link_funcs[] declaration. */ + +#if defined(__DECC) && defined(__osf__) +#pragma message save +#pragma message disable (nonstandcast) +#endif #include "thrdvar.h" #include "intrpvar.h" #include "perlvars.h" +#if defined(__DECC) && defined(__osf__) +#pragma message restore +#endif + #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC }; #endif /* DOINIT */ @@ -795,23 +875,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" @@ -826,14 +894,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; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(aTHX->v); } + { dVAR; PERL_UNUSED_CONTEXT; 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; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #include "thrdvar.h" #include "intrpvar.h" @@ -841,25 +912,54 @@ START_EXTERN_C #undef PERLVAR #undef PERLVARA #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #undef PERLVARIC -#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \ - { return (const t *)&(PL_##v); } +#undef PERLVARISC +#define PERLVARIC(v,t,i) \ + const t* Perl_##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 + +#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 Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr; + PERL_UNUSED_CONTEXT; + return (Perl_ppaddr_t**)&ppaddr_ptr; +} +Perl_check_t** Perl_Gcheck_ptr(pTHX) { + static Perl_check_t* const check_ptr = PL_check; + PERL_UNUSED_CONTEXT; + return (Perl_check_t**)&check_ptr; +} +unsigned char** Perl_Gfold_locale_ptr(pTHX) { + static unsigned char* const fold_locale_ptr = PL_fold_locale; + PERL_UNUSED_CONTEXT; + 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 @@ -881,3 +981,5 @@ my %vfuncs = qw( Perl_dump_indent Perl_dump_vindent Perl_default_protect Perl_vdefault_protect ); + +# ex: set ts=8 sts=4 sw=4 noet: