1#!/usr/bin/perl -w 2# 3# Regenerate (overwriting only if changed): 4# 5# embed.h 6# embedvar.h 7# perlapi.c 8# perlapi.h 9# proto.h 10# 11# from information stored in 12# 13# embed.fnc 14# intrpvar.h 15# perlvars.h 16# regen/opcodes 17# 18# Accepts the standard regen_lib -q and -v args. 19# 20# This script is normally invoked from regen.pl. 21 22require 5.004; # keep this compatible, an old perl is all we may have before 23 # we build the new one 24 25use strict; 26 27BEGIN { 28 # Get function prototypes 29 require './regen/regen_lib.pl'; 30 require './regen/embed_lib.pl'; 31} 32 33my $unflagged_pointers; 34 35# 36# See database of global and static function prototypes in embed.fnc 37# This is used to generate prototype headers under various configurations, 38# export symbols lists for different platforms, and macros to provide an 39# implicit interpreter context argument. 40# 41 42my $error_count = 0; 43sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't 44 # succeed. 45 warn shift; 46 $error_count++; 47} 48 49sub full_name ($$) { # Returns the function name with potentially the 50 # prefixes 'S_' or 'Perl_' 51 my ($func, $flags) = @_; 52 53 return "Perl_$func" if $flags =~ /p/; 54 return "S_$func" if $flags =~ /[si]/; 55 return $func; 56} 57 58sub open_print_header { 59 my ($file, $quote) = @_; 60 61 return open_new($file, '>', 62 { file => $file, style => '*', by => 'regen/embed.pl', 63 from => ['data in embed.fnc', 'regen/embed.pl', 64 'regen/opcodes', 'intrpvar.h', 'perlvars.h'], 65 final => "\nEdit those files and run 'make regen_headers' to effect changes.\n", 66 copyright => [1993 .. 2009], quote => $quote }); 67} 68 69my ($embed, $core, $ext, $api) = setup_embed(); 70 71# generate proto.h 72{ 73 my $pr = open_print_header("proto.h"); 74 print $pr "START_EXTERN_C\n"; 75 my $ret; 76 77 foreach (@$embed) { 78 if (@$_ == 1) { 79 print $pr "$_->[0]\n"; 80 next; 81 } 82 83 my ($flags,$retval,$plain_func,@args) = @$_; 84 if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUWXx] ) /x) { 85 die_at_end "flag $1 is not legal (for function $plain_func)"; 86 } 87 my @nonnull; 88 my $has_depth = ( $flags =~ /W/ ); 89 my $has_context = ( $flags !~ /n/ ); 90 my $never_returns = ( $flags =~ /r/ ); 91 my $binarycompat = ( $flags =~ /b/ ); 92 my $commented_out = ( ! $binarycompat && $flags =~ /m/ ); 93 my $is_malloc = ( $flags =~ /a/ ); 94 my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc; 95 my @names_of_nn; 96 my $func; 97 98 if (! $can_ignore && $retval eq 'void') { 99 warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked"; 100 } 101 102 die_at_end "$plain_func: s flag is mutually exclusive from the i and p plags" 103 if $flags =~ /s/ && $flags =~ /[ip]/; 104 105 my $static_inline = 0; 106 if ($flags =~ /([si])/) { 107 my $type; 108 if ($never_returns) { 109 $type = $1 eq 's' ? "PERL_STATIC_NO_RET" : "PERL_STATIC_INLINE_NO_RET"; 110 } 111 else { 112 $type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE"; 113 } 114 $retval = "$type $retval"; 115 die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/; 116 $static_inline = $type eq 'PERL_STATIC_INLINE'; 117 } 118 else { 119 if ($never_returns) { 120 $retval = "PERL_CALLCONV_NO_RET $retval"; 121 } 122 else { 123 $retval = "PERL_CALLCONV $retval"; 124 } 125 } 126 $func = full_name($plain_func, $flags); 127 $ret = ""; 128 $ret .= "#ifndef NO_MATHOMS\n" if $binarycompat; 129 $ret .= "#ifndef PERL_NO_INLINE_FUNCTIONS\n" if $static_inline; 130 $ret .= "$retval\t$func("; 131 if ( $has_context ) { 132 $ret .= @args ? "pTHX_ " : "pTHX"; 133 } 134 if (@args) { 135 my $n; 136 for my $arg ( @args ) { 137 ++$n; 138 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) { 139 warn "$func: $arg needs NN or NULLOK\n"; 140 ++$unflagged_pointers; 141 } 142 my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); 143 push( @nonnull, $n ) if $nn; 144 145 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect 146 147 # Make sure each arg has at least a type and a var name. 148 # An arg of "int" is valid C, but want it to be "int foo". 149 my $temp_arg = $arg; 150 $temp_arg =~ s/\*//g; 151 $temp_arg =~ s/\s*\bstruct\b\s*/ /g; 152 if ( ($temp_arg ne "...") 153 && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { 154 die_at_end "$func: $arg ($n) doesn't have a name\n"; 155 } 156 if (defined $1 && $nn && !($commented_out && !$binarycompat)) { 157 push @names_of_nn, $1; 158 } 159 } 160 $ret .= join ", ", @args; 161 } 162 else { 163 $ret .= "void" if !$has_context; 164 } 165 $ret .= " _pDEPTH" if $has_depth; 166 $ret .= ")"; 167 my @attrs; 168 if ( $flags =~ /r/ ) { 169 push @attrs, "__attribute__noreturn__"; 170 } 171 if ( $flags =~ /D/ ) { 172 push @attrs, "__attribute__deprecated__"; 173 } 174 if ( $is_malloc ) { 175 push @attrs, "__attribute__malloc__"; 176 } 177 if ( !$can_ignore ) { 178 push @attrs, "__attribute__warn_unused_result__"; 179 } 180 if ( $flags =~ /P/ ) { 181 push @attrs, "__attribute__pure__"; 182 } 183 if( $flags =~ /f/ ) { 184 my $prefix = $has_context ? 'pTHX_' : ''; 185 my ($args, $pat); 186 if ($args[-1] eq '...') { 187 $args = scalar @args; 188 $pat = $args - 1; 189 $args = $prefix . $args; 190 } 191 else { 192 # don't check args, and guess which arg is the pattern 193 # (one of 'fmt', 'pat', 'f'), 194 $args = 0; 195 my @fmts = grep $args[$_] =~ /\b(f|pat|fmt)$/, 0..$#args; 196 if (@fmts != 1) { 197 die "embed.pl: '$plain_func': can't determine pattern arg\n"; 198 } 199 $pat = $fmts[0] + 1; 200 } 201 my $macro = grep($_ == $pat, @nonnull) 202 ? '__attribute__format__' 203 : '__attribute__format__null_ok__'; 204 if ($plain_func =~ /strftime/) { 205 push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix; 206 } 207 else { 208 push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro, 209 $prefix, $pat, $args; 210 } 211 } 212 if ( @attrs ) { 213 $ret .= "\n"; 214 $ret .= join( "\n", map { "\t\t\t$_" } @attrs ); 215 } 216 $ret .= ";"; 217 $ret = "/* $ret */" if $commented_out; 218 if (@names_of_nn) { 219 $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t" 220 . join '; ', map "assert($_)", @names_of_nn; 221 } 222 $ret .= "\n#endif" if $static_inline; 223 $ret .= "\n#endif" if $binarycompat; 224 $ret .= @attrs ? "\n\n" : "\n"; 225 226 print $pr $ret; 227 } 228 229 print $pr <<'EOF'; 230#ifdef PERL_CORE 231# include "pp_proto.h" 232#endif 233END_EXTERN_C 234EOF 235 236 read_only_bottom_close_and_rename($pr) if ! $error_count; 237} 238 239die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; 240 241sub readvars { 242 my ($file, $pre) = @_; 243 local (*FILE, $_); 244 my %seen; 245 open(FILE, '<', $file) 246 or die "embed.pl: Can't open $file: $!\n"; 247 while (<FILE>) { 248 s/[ \t]*#.*//; # Delete comments. 249 if (/PERLVARA?I?C?\($pre,\s*(\w+)/) { 250 die_at_end "duplicate symbol $1 while processing $file line $.\n" 251 if $seen{$1}++; 252 } 253 } 254 close(FILE); 255 return sort keys %seen; 256} 257 258my @intrp = readvars 'intrpvar.h','I'; 259my @globvar = readvars 'perlvars.h','G'; 260 261sub hide { 262 my ($from, $to, $indent) = @_; 263 $indent = '' unless defined $indent; 264 my $t = int(length("$indent$from") / 8); 265 "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n"; 266} 267 268sub multon ($$$) { 269 my ($sym,$pre,$ptr) = @_; 270 hide("PL_$sym", "($ptr$pre$sym)"); 271} 272 273my $em = open_print_header('embed.h'); 274 275print $em <<'END'; 276/* (Doing namespace management portably in C is really gross.) */ 277 278/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms 279 * (like warn instead of Perl_warn) for the API are not defined. 280 * Not defining the short forms is a good thing for cleaner embedding. */ 281 282#ifndef PERL_NO_SHORT_NAMES 283 284/* Hide global symbols */ 285 286END 287 288my @az = ('a'..'z'); 289 290sub embed_h { 291 my ($guard, $funcs) = @_; 292 print $em "$guard\n" if $guard; 293 294 my $lines; 295 foreach (@$funcs) { 296 if (@$_ == 1) { 297 my $cond = $_->[0]; 298 # Indent the conditionals if we are wrapped in an #if/#endif pair. 299 $cond =~ s/#(.*)/# $1/ if $guard; 300 $lines .= "$cond\n"; 301 next; 302 } 303 my $ret = ""; 304 my ($flags,$retval,$func,@args) = @$_; 305 unless ($flags =~ /[om]/) { 306 my $args = scalar @args; 307 if ($flags =~ /n/) { 308 my $full_name = full_name($func, $flags); 309 next if $full_name eq $func; # Don't output a no-op. 310 $ret = hide($func, $full_name); 311 } 312 elsif ($args and $args[$args-1] =~ /\.\.\./) { 313 if ($flags =~ /p/) { 314 # we're out of luck for varargs functions under CPP 315 # So we can only do these macros for no implicit context: 316 $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n" 317 . hide($func, full_name($func, $flags)) . "#endif\n"; 318 } 319 } 320 else { 321 my $alist = join(",", @az[0..$args-1]); 322 $ret = "#define $func($alist)"; 323 my $t = int(length($ret) / 8); 324 $ret .= "\t" x ($t < 4 ? 4 - $t : 1); 325 $ret .= full_name($func, $flags) . "(aTHX"; 326 $ret .= "_ " if $alist; 327 $ret .= $alist; 328 if ($flags =~ /W/) { 329 if ($alist) { 330 $ret .= " _aDEPTH"; 331 } else { 332 die "Can't use W without other args (currently)"; 333 } 334 } 335 $ret .= ")\n"; 336 } 337 $ret = "#ifndef NO_MATHOMS\n$ret#endif\n" if $flags =~ /b/; 338 } 339 $lines .= $ret; 340 } 341 # Prune empty #if/#endif pairs. 342 while ($lines =~ s/#\s*if[^\n]+\n#\s*endif\n//) { 343 } 344 # Merge adjacent blocks. 345 while ($lines =~ s/(#ifndef PERL_IMPLICIT_CONTEXT 346[^\n]+ 347)#endif 348#ifndef PERL_IMPLICIT_CONTEXT 349/$1/) { 350 } 351 352 print $em $lines; 353 print $em "#endif\n" if $guard; 354} 355 356embed_h('', $api); 357embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', $ext); 358embed_h('#ifdef PERL_CORE', $core); 359 360print $em <<'END'; 361 362#endif /* #ifndef PERL_NO_SHORT_NAMES */ 363 364/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to 365 disable them. 366 */ 367 368#if !defined(PERL_CORE) 369# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) 370# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) 371#endif 372 373#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) 374 375/* Compatibility for various misnamed functions. All functions 376 in the API that begin with "perl_" (not "Perl_") take an explicit 377 interpreter context pointer. 378 The following are not like that, but since they had a "perl_" 379 prefix in previous versions, we provide compatibility macros. 380 */ 381# define perl_atexit(a,b) call_atexit(a,b) 382END 383 384foreach (@$embed) { 385 my ($flags, $retval, $func, @args) = @$_; 386 next unless $func; 387 next unless $flags =~ /O/; 388 389 my $alist = join ",", @az[0..$#args]; 390 my $ret = "# define perl_$func($alist)"; 391 my $t = (length $ret) >> 3; 392 $ret .= "\t" x ($t < 5 ? 5 - $t : 1); 393 print $em "$ret$func($alist)\n"; 394} 395 396my @nocontext; 397{ 398 my (%has_va, %has_nocontext); 399 foreach (@$embed) { 400 next unless @$_ > 1; 401 ++$has_va{$_->[2]} if $_->[-1] =~ /\.\.\./; 402 ++$has_nocontext{$1} if $_->[2] =~ /(.*)_nocontext/; 403 } 404 405 @nocontext = sort grep { 406 $has_nocontext{$_} 407 && !/printf/ # Not clear to me why these are skipped but they are. 408 } keys %has_va; 409} 410 411print $em <<'END'; 412 413/* varargs functions can't be handled with CPP macros. :-( 414 This provides a set of compatibility functions that don't take 415 an extra argument but grab the context pointer using the macro 416 dTHX. 417 */ 418#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES) 419END 420 421foreach (@nocontext) { 422 print $em hide($_, "Perl_${_}_nocontext", " "); 423} 424 425print $em <<'END'; 426#endif 427 428#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ 429 430#if !defined(PERL_IMPLICIT_CONTEXT) 431/* undefined symbols, point them back at the usual ones */ 432END 433 434foreach (@nocontext) { 435 print $em hide("Perl_${_}_nocontext", "Perl_$_", " "); 436} 437 438print $em <<'END'; 439#endif 440END 441 442read_only_bottom_close_and_rename($em) if ! $error_count; 443 444$em = open_print_header('embedvar.h'); 445 446print $em <<'END'; 447/* (Doing namespace management portably in C is really gross.) */ 448 449/* 450 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT 451 are supported: 452 1) none 453 2) MULTIPLICITY # supported for compatibility 454 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT 455 456 All other combinations of these flags are errors. 457 458 only #3 is supported directly, while #2 is a special 459 case of #3 (supported by redefining vTHX appropriately). 460*/ 461 462#if defined(MULTIPLICITY) 463/* cases 2 and 3 above */ 464 465# if defined(PERL_IMPLICIT_CONTEXT) 466# define vTHX aTHX 467# else 468# define vTHX PERL_GET_INTERP 469# endif 470 471END 472 473my $sym; 474 475for $sym (@intrp) { 476 if ($sym eq 'sawampersand') { 477 print $em "#ifndef PL_sawampersand\n"; 478 } 479 print $em multon($sym,'I','vTHX->'); 480 if ($sym eq 'sawampersand') { 481 print $em "#endif\n"; 482 } 483} 484 485print $em <<'END'; 486 487#endif /* MULTIPLICITY */ 488 489#if defined(PERL_GLOBAL_STRUCT) 490 491END 492 493for $sym (@globvar) { 494 print $em "#ifdef OS2\n" if $sym eq 'sh_path'; 495 print $em "#ifdef __VMS\n" if $sym eq 'perllib_sep'; 496 print $em multon($sym, 'G','my_vars->'); 497 print $em multon("G$sym",'', 'my_vars->'); 498 print $em "#endif\n" if $sym eq 'sh_path'; 499 print $em "#endif\n" if $sym eq 'perllib_sep'; 500} 501 502print $em <<'END'; 503 504#endif /* PERL_GLOBAL_STRUCT */ 505END 506 507read_only_bottom_close_and_rename($em) if ! $error_count; 508 509my $capih = open_print_header('perlapi.h'); 510 511print $capih <<'EOT'; 512/* declare accessor functions for Perl variables */ 513#ifndef __perlapi_h__ 514#define __perlapi_h__ 515 516#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT) 517 518START_EXTERN_C 519 520#undef PERLVAR 521#undef PERLVARA 522#undef PERLVARI 523#undef PERLVARIC 524#define PERLVAR(p,v,t) EXTERN_C t* Perl_##p##v##_ptr(pTHX); 525#define PERLVARA(p,v,n,t) typedef t PL_##v##_t[n]; \ 526 EXTERN_C PL_##v##_t* Perl_##p##v##_ptr(pTHX); 527#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) 528#define PERLVARIC(p,v,t,i) PERLVAR(p,v, const t) 529 530#include "perlvars.h" 531 532#undef PERLVAR 533#undef PERLVARA 534#undef PERLVARI 535#undef PERLVARIC 536 537END_EXTERN_C 538 539#if defined(PERL_CORE) 540 541/* accessor functions for Perl "global" variables */ 542 543/* these need to be mentioned here, or most linkers won't put them in 544 the perl executable */ 545 546#ifndef PERL_NO_FORCE_LINK 547 548START_EXTERN_C 549 550#ifndef DOINIT 551EXTCONST void * const PL_force_link_funcs[]; 552#else 553EXTCONST void * const PL_force_link_funcs[] = { 554#undef PERLVAR 555#undef PERLVARA 556#undef PERLVARI 557#undef PERLVARIC 558#define PERLVAR(p,v,t) (void*)Perl_##p##v##_ptr, 559#define PERLVARA(p,v,n,t) PERLVAR(p,v,t) 560#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) 561#define PERLVARIC(p,v,t,i) PERLVAR(p,v,t) 562 563/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one 564 * cannot cast between void pointers and function pointers without 565 * info level warnings. The PL_force_link_funcs[] would cause a few 566 * hundred of those warnings. In code one can circumnavigate this by using 567 * unions that overlay the different pointers, but in declarations one 568 * cannot use this trick. Therefore we just disable the warning here 569 * for the duration of the PL_force_link_funcs[] declaration. */ 570 571#if defined(__DECC) && defined(__osf__) 572#pragma message save 573#pragma message disable (nonstandcast) 574#endif 575 576#include "perlvars.h" 577 578#if defined(__DECC) && defined(__osf__) 579#pragma message restore 580#endif 581 582#undef PERLVAR 583#undef PERLVARA 584#undef PERLVARI 585#undef PERLVARIC 586}; 587#endif /* DOINIT */ 588 589END_EXTERN_C 590 591#endif /* PERL_NO_FORCE_LINK */ 592 593#else /* !PERL_CORE */ 594 595EOT 596 597foreach $sym (@globvar) { 598 print $capih 599 "#undef PL_$sym\n" . hide("PL_$sym", "(*Perl_G${sym}_ptr(NULL))"); 600} 601 602print $capih <<'EOT'; 603 604#endif /* !PERL_CORE */ 605#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ 606 607#endif /* __perlapi_h__ */ 608EOT 609 610read_only_bottom_close_and_rename($capih) if ! $error_count; 611 612my $capi = open_print_header('perlapi.c', <<'EOQ'); 613 * 614 * 615 * Up to the threshold of the door there mounted a flight of twenty-seven 616 * broad stairs, hewn by some unknown art of the same black stone. This 617 * was the only entrance to the tower; ... 618 * 619 * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"] 620 * 621 */ 622EOQ 623 624print $capi <<'EOT'; 625#include "EXTERN.h" 626#include "perl.h" 627#include "perlapi.h" 628 629#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT) 630 631/* accessor functions for Perl "global" variables */ 632START_EXTERN_C 633 634#undef PERLVARI 635#define PERLVARI(p,v,t,i) PERLVAR(p,v,t) 636 637#undef PERLVAR 638#undef PERLVARA 639#define PERLVAR(p,v,t) t* Perl_##p##v##_ptr(pTHX) \ 640 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } 641#define PERLVARA(p,v,n,t) PL_##v##_t* Perl_##p##v##_ptr(pTHX) \ 642 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } 643#undef PERLVARIC 644#define PERLVARIC(p,v,t,i) \ 645 const t* Perl_##p##v##_ptr(pTHX) \ 646 { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); } 647#include "perlvars.h" 648 649#undef PERLVAR 650#undef PERLVARA 651#undef PERLVARI 652#undef PERLVARIC 653 654END_EXTERN_C 655 656#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ 657EOT 658 659read_only_bottom_close_and_rename($capi) if ! $error_count; 660 661die "$error_count errors found" if $error_count; 662 663# ex: set ts=8 sts=4 sw=4 noet: 664