#!/usr/bin/perl -w
-#
+#
# Regenerate (overwriting only if changed):
#
# embed.h
# embedvar.h
-# perlapi.c
-# perlapi.h
# proto.h
#
# from information stored in
my ($func, $flags) = @_;
return "Perl_$func" if $flags =~ /p/;
- return "S_$func" if $flags =~ /[si]/;
+ return "S_$func" if $flags =~ /[SIi]/;
return $func;
}
}
my ($flags,$retval,$plain_func,@args) = @$_;
- if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUWXx] ) /x) {
+ if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx] ) /x) {
die_at_end "flag $1 is not legal (for function $plain_func)";
}
my @nonnull;
+ my $args_assert_line = ( $flags !~ /G/ );
my $has_depth = ( $flags =~ /W/ );
- my $has_context = ( $flags !~ /n/ );
+ 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/ ) && ( $flags !~ /P/ ) && !$is_malloc;
my @names_of_nn;
warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
}
- die_at_end "$plain_func: s flag is mutually exclusive from the i and p plags"
- if $flags =~ /s/ && $flags =~ /[ip]/;
+ 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/;
my $static_inline = 0;
- if ($flags =~ /([si])/) {
+ 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 $retval";
die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/;
- $static_inline = $type eq 'PERL_STATIC_INLINE';
+ $static_inline = $type =~ /^PERL_STATIC(?:_FORCE)?_INLINE/;
}
else {
if ($never_returns) {
$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 .= "#ifndef PERL_NO_INLINE_FUNCTIONS\n" if $static_inline;
$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;
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 $static_inline;
- $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;
}
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);
print $em <<'END';
#endif /* MULTIPLICITY */
-
-#if defined(PERL_GLOBAL_STRUCT)
-
-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';
-
-#endif /* PERL_GLOBAL_STRUCT */
END
read_only_bottom_close_and_rename($em) if ! $error_count;
-my $capih = open_print_header('perlapi.h');
-
-print $capih <<'EOT';
-/* declare accessor functions for Perl variables */
-#ifndef __perlapi_h__
-#define __perlapi_h__
-
-#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
-
-START_EXTERN_C
-
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-#define PERLVAR(p,v,t) EXTERN_C t* Perl_##p##v##_ptr(pTHX);
-#define PERLVARA(p,v,n,t) typedef t PL_##v##_t[n]; \
- EXTERN_C PL_##v##_t* Perl_##p##v##_ptr(pTHX);
-#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
-#define PERLVARIC(p,v,t,i) PERLVAR(p,v, const t)
-
-#include "perlvars.h"
-
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-
-END_EXTERN_C
-
-#if defined(PERL_CORE)
-
-/* accessor functions for Perl "global" variables */
-
-/* these need to be mentioned here, or most linkers won't put them in
- the perl executable */
-
-#ifndef PERL_NO_FORCE_LINK
-
-START_EXTERN_C
-
-#ifndef DOINIT
-EXTCONST void * const PL_force_link_funcs[];
-#else
-EXTCONST void * const PL_force_link_funcs[] = {
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-#define PERLVAR(p,v,t) (void*)Perl_##p##v##_ptr,
-#define PERLVARA(p,v,n,t) PERLVAR(p,v,t)
-#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
-#define PERLVARIC(p,v,t,i) PERLVAR(p,v,t)
-
-/* 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 "perlvars.h"
-
-#if defined(__DECC) && defined(__osf__)
-#pragma message restore
-#endif
-
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-};
-#endif /* DOINIT */
-
-END_EXTERN_C
-
-#endif /* PERL_NO_FORCE_LINK */
-
-#else /* !PERL_CORE */
-
-EOT
-
-foreach $sym (@globvar) {
- print $capih
- "#undef PL_$sym\n" . hide("PL_$sym", "(*Perl_G${sym}_ptr(NULL))");
-}
-
-print $capih <<'EOT';
-
-#endif /* !PERL_CORE */
-#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
-
-#endif /* __perlapi_h__ */
-EOT
-
-read_only_bottom_close_and_rename($capih) if ! $error_count;
-
-my $capi = open_print_header('perlapi.c', <<'EOQ');
- *
- *
- * 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; ...
- *
- * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
- *
- */
-EOQ
-
-print $capi <<'EOT';
-#include "EXTERN.h"
-#include "perl.h"
-#include "perlapi.h"
-
-#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
-
-/* accessor functions for Perl "global" variables */
-START_EXTERN_C
-
-#undef PERLVARI
-#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
-
-#undef PERLVAR
-#undef PERLVARA
-#define PERLVAR(p,v,t) t* Perl_##p##v##_ptr(pTHX) \
- { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
-#define PERLVARA(p,v,n,t) PL_##v##_t* Perl_##p##v##_ptr(pTHX) \
- { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
-#undef PERLVARIC
-#define PERLVARIC(p,v,t,i) \
- const t* Perl_##p##v##_ptr(pTHX) \
- { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
-#include "perlvars.h"
-
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-
-END_EXTERN_C
-
-#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
-EOT
-
-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