Move OP prototypes from pp_proto.h to proto.h
[perl.git] / embed.pl
1 #!/usr/bin/perl -w
2
3 # Regenerate (overwriting only if changed):
4 #
5 #    embed.h
6 #    embedvar.h
7 #    global.sym
8 #    perlapi.c
9 #    perlapi.h
10 #    proto.h
11 #
12 # from information stored in
13 #
14 #    embed.fnc
15 #    intrpvar.h
16 #    perlvars.h
17 #    pp.sym     (which has been generated by opcode.pl)
18 #
19 # Accepts the standard regen_lib -q and -v args.
20 #
21 # This script is normally invoked from regen.pl.
22
23 require 5.004;  # keep this compatible, an old perl is all we may have before
24                 # we build the new one
25
26 use strict;
27
28 BEGIN {
29     # Get function prototypes
30     require 'regen_lib.pl';
31 }
32
33 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
34 my $unflagged_pointers;
35
36 #
37 # See database of global and static function prototypes in embed.fnc
38 # This is used to generate prototype headers under various configurations,
39 # export symbols lists for different platforms, and macros to provide an
40 # implicit interpreter context argument.
41 #
42
43 sub do_not_edit ($)
44 {
45     my $file = shift;
46
47     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
48
49     $years =~ s/1999,/1999,\n  / if length $years > 40;
50
51     my $warning = <<EOW;
52  -*- buffer-read-only: t -*-
53
54    $file
55
56    Copyright (C) $years, by Larry Wall and others
57
58    You may distribute under the terms of either the GNU General Public
59    License or the Artistic License, as specified in the README file.
60
61 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
62 This file is built by embed.pl from data in embed.fnc, embed.pl,
63 pp.sym, intrpvar.h, and perlvars.h.
64 Any changes made here will be lost!
65
66 Edit those files and run 'make regen_headers' to effect changes.
67
68 EOW
69
70     $warning .= <<EOW if $file eq 'perlapi.c';
71
72 Up to the threshold of the door there mounted a flight of twenty-seven
73 broad stairs, hewn by some unknown art of the same black stone.  This
74 was the only entrance to the tower; ...
75
76     [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
77
78
79 EOW
80
81     if ($file =~ m:\.[ch]$:) {
82         $warning =~ s:^: * :gm;
83         $warning =~ s: +$::gm;
84         $warning =~ s: :/:;
85         $warning =~ s:$:/:;
86     }
87     else {
88         $warning =~ s:^:# :gm;
89         $warning =~ s: +$::gm;
90     }
91     $warning;
92 } # do_not_edit
93
94 open IN, "embed.fnc" or die $!;
95
96 my @embed;
97 my (%has_va, %has_nocontext);
98
99 while (<IN>) {
100     chomp;
101     next if /^:/;
102     while (s|\\$||) {
103         $_ .= <IN>;
104         chomp;
105     }
106     s/\s+$//;
107     my @args;
108     if (/^\s*(#|$)/) {
109         @args = $_;
110     }
111     else {
112         @args = split /\s*\|\s*/, $_;
113         my $func = $args[2];
114         if ($func) {
115             ++$has_va{$func} if $args[-1] =~ /\.\.\./;
116             ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
117         }
118     }
119     push @embed, \@args;
120 }
121
122 open IN, 'pp.sym' or die $!;
123 {
124     my %syms;
125
126     while (<IN>) {
127         s/[ \t]*#.*//;          # Delete comments.
128         if (/^\s*(\S+)\s*$/) {
129             my $sym = $1;
130             warn "duplicate symbol $sym while processing 'pp.sym' line $.\n"
131                 if $syms{$sym}++;
132         }
133     }
134
135     foreach (sort keys %syms) {
136         s/^Perl_//;
137         if (/^ck_/) {
138             # These are all indirectly referenced by globals.c.
139             # This is somewhat annoying.
140             push @embed, ['pR', 'OP *', $_, 'NN OP *o'];
141         }
142         elsif (/^pp_/) {
143             push @embed, ['p', 'OP *', $_];
144         }
145         else {
146             warn "Illegal symbol '$_' in pp.sym";
147         }
148     }
149 }
150
151 # walk table providing an array of components in each line to
152 # subroutine, printing the result
153 sub walk_table (&@) {
154     my ($function, $filename, $trailer) = @_;
155     my $F;
156     if (ref $filename) {        # filehandle
157         $F = $filename;
158     }
159     else {
160         $F = safer_open("$filename-new");
161         print $F do_not_edit ($filename);
162     }
163     foreach (@embed) {
164         my @outs = &{$function}(@$_);
165         # $function->(@args) is not 5.003
166         print $F @outs;
167     }
168     print $F $trailer if $trailer;
169     unless (ref $filename) {
170         safer_close($F);
171         rename_if_different("$filename-new", $filename);
172     }
173 }
174
175 # generate proto.h
176 my $wrote_protected = 0;
177
178 sub write_protos {
179     my $ret;
180     if (@_ == 1) {
181         my $arg = shift;
182         $ret = "$arg\n";
183     }
184     else {
185         my ($flags,$retval,$plain_func,@args) = @_;
186         my @nonnull;
187         my $has_context = ( $flags !~ /n/ );
188         my $never_returns = ( $flags =~ /r/ );
189         my $commented_out = ( $flags =~ /m/ );
190         my $binarycompat = ( $flags =~ /b/ );
191         my $is_malloc = ( $flags =~ /a/ );
192         my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
193         my @names_of_nn;
194         my $func;
195
196         my $splint_flags = "";
197         if ( $SPLINT && !$commented_out ) {
198             $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
199             if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
200                 $retval .= " /*\@alt void\@*/";
201             }
202         }
203
204         if ($flags =~ /s/) {
205             $retval = "STATIC $splint_flags$retval";
206             $func = "S_$plain_func";
207         }
208         else {
209             $retval = "PERL_CALLCONV $splint_flags$retval";
210             if ($flags =~ /[bp]/) {
211                 $func = "Perl_$plain_func";
212             } else {
213                 $func = $plain_func;
214             }
215         }
216         $ret = "$retval\t$func(";
217         if ( $has_context ) {
218             $ret .= @args ? "pTHX_ " : "pTHX";
219         }
220         if (@args) {
221             my $n;
222             for my $arg ( @args ) {
223                 ++$n;
224                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
225                     warn "$func: $arg needs NN or NULLOK\n";
226                     ++$unflagged_pointers;
227                 }
228                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
229                 push( @nonnull, $n ) if $nn;
230
231                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
232
233                 # Make sure each arg has at least a type and a var name.
234                 # An arg of "int" is valid C, but want it to be "int foo".
235                 my $temp_arg = $arg;
236                 $temp_arg =~ s/\*//g;
237                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
238                 if ( ($temp_arg ne "...")
239                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
240                     warn "$func: $arg ($n) doesn't have a name\n";
241                 }
242                 if ( $SPLINT && $nullok && !$commented_out ) {
243                     $arg = '/*@null@*/ ' . $arg;
244                 }
245                 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
246                     push @names_of_nn, $1;
247                 }
248             }
249             $ret .= join ", ", @args;
250         }
251         else {
252             $ret .= "void" if !$has_context;
253         }
254         $ret .= ")";
255         my @attrs;
256         if ( $flags =~ /r/ ) {
257             push @attrs, "__attribute__noreturn__";
258         }
259         if ( $flags =~ /D/ ) {
260             push @attrs, "__attribute__deprecated__";
261         }
262         if ( $is_malloc ) {
263             push @attrs, "__attribute__malloc__";
264         }
265         if ( !$can_ignore ) {
266             push @attrs, "__attribute__warn_unused_result__";
267         }
268         if ( $flags =~ /P/ ) {
269             push @attrs, "__attribute__pure__";
270         }
271         if( $flags =~ /f/ ) {
272             my $prefix  = $has_context ? 'pTHX_' : '';
273             my $args    = scalar @args;
274             my $pat     = $args - 1;
275             my $macro   = @nonnull && $nonnull[-1] == $pat  
276                                 ? '__attribute__format__'
277                                 : '__attribute__format__null_ok__';
278             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
279                                 $prefix, $pat, $prefix, $args;
280         }
281         if ( @nonnull ) {
282             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
283             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
284         }
285         if ( @attrs ) {
286             $ret .= "\n";
287             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
288         }
289         $ret .= ";";
290         $ret = "/* $ret */" if $commented_out;
291         if (@names_of_nn) {
292             $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
293                 . join '; ', map "assert($_)", @names_of_nn;
294         }
295         $ret .= @attrs ? "\n\n" : "\n";
296     }
297     $ret;
298 }
299
300 # generates global.sym (API export list)
301 {
302   my %seen;
303   sub write_global_sym {
304       if (@_ > 1) {
305           my ($flags,$retval,$func,@args) = @_;
306           # If a function is defined twice, for example before and after an
307           # #else, only process the flags on the first instance for global.sym
308           return '' if $seen{$func}++;
309           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
310               || $flags =~ /b/) { # public API, so export
311               $func = "Perl_$func" if $flags =~ /[pbX]/;
312               return "$func\n";
313           }
314       }
315       return '';
316   }
317 }
318
319 {
320     my $pr = safer_open('proto.h-new');
321
322     print $pr do_not_edit ("proto.h"), "\nSTART_EXTERN_C\n";
323
324     walk_table(\&write_protos, $pr);
325
326     print $pr "END_EXTERN_C\n/* ex: set ro: */\n";
327
328     safer_close($pr);
329     rename_if_different('proto.h-new', 'proto.h');
330 }
331
332 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
333 walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n");
334
335 sub readvars(\%$$@) {
336     my ($syms, $file,$pre,$keep_pre) = @_;
337     local (*FILE, $_);
338     open(FILE, "< $file")
339         or die "embed.pl: Can't open $file: $!\n";
340     while (<FILE>) {
341         s/[ \t]*#.*//;          # Delete comments.
342         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
343             my $sym = $1;
344             $sym = $pre . $sym if $keep_pre;
345             warn "duplicate symbol $sym while processing $file line $.\n"
346                 if exists $$syms{$sym};
347             $$syms{$sym} = $pre || 1;
348         }
349     }
350     close(FILE);
351 }
352
353 my %intrp;
354 my %globvar;
355
356 readvars %intrp,  'intrpvar.h','I';
357 readvars %globvar, 'perlvars.h','G';
358
359 my $sym;
360
361 sub undefine ($) {
362     my ($sym) = @_;
363     "#undef  $sym\n";
364 }
365
366 sub hide {
367     my ($from, $to, $indent) = @_;
368     $indent = '' unless defined $indent;
369     my $t = int(length("$indent$from") / 8);
370     "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
371 }
372
373 sub bincompat_var ($$) {
374     my ($pfx, $sym) = @_;
375     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
376     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
377 }
378
379 sub multon ($$$) {
380     my ($sym,$pre,$ptr) = @_;
381     hide("PL_$sym", "($ptr$pre$sym)");
382 }
383
384 sub multoff ($$) {
385     my ($sym,$pre) = @_;
386     return hide("PL_$pre$sym", "PL_$sym");
387 }
388
389 my $em = safer_open('embed.h-new');
390
391 print $em do_not_edit ("embed.h"), <<'END';
392
393 /* (Doing namespace management portably in C is really gross.) */
394
395 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
396  * (like warn instead of Perl_warn) for the API are not defined.
397  * Not defining the short forms is a good thing for cleaner embedding. */
398
399 #ifndef PERL_NO_SHORT_NAMES
400
401 /* Hide global symbols */
402
403 END
404
405 # Try to elimiate lots of repeated
406 # #ifdef PERL_CORE
407 # foo
408 # #endif
409 # #ifdef PERL_CORE
410 # bar
411 # #endif
412 # by tracking state and merging foo and bar into one block.
413 my $ifdef_state = '';
414
415 my @az = ('a'..'z');
416
417 walk_table {
418     my $ret = "";
419     my $new_ifdef_state = '';
420     if (@_ == 1) {
421         my $arg = shift;
422         $ret = "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
423     }
424     else {
425         my ($flags,$retval,$func,@args) = @_;
426         unless ($flags =~ /[om]/) {
427             my $args = scalar @args;
428             if ($flags =~ /n/) {
429                 if ($flags =~ /s/) {
430                     $ret = hide($func,"S_$func");
431                 }
432                 elsif ($flags =~ /p/) {
433                     $ret = hide($func,"Perl_$func");
434                 }
435             }
436             elsif ($args and $args[$args-1] =~ /\.\.\./) {
437                 if ($flags =~ /p/) {
438                     # we're out of luck for varargs functions under CPP
439                     # So we can only do these macros for no implicit context:
440                     $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
441                         . hide($func,"Perl_$func") . "#endif\n";
442                 }
443             }
444             else {
445                 my $alist = join(",", @az[0..$args-1]);
446                 $ret = "#define $func($alist)";
447                 my $t = int(length($ret) / 8);
448                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
449                 if ($flags =~ /s/) {
450                     $ret .= "S_$func(aTHX";
451                 }
452                 elsif ($flags =~ /p/) {
453                     $ret .= "Perl_$func(aTHX";
454                 }
455                 $ret .= "_ " if $alist;
456                 $ret .= $alist . ")\n";
457             }
458         }
459         unless ($flags =~ /A/) {
460             if ($flags =~ /E/) {
461                 $new_ifdef_state
462                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
463             }
464             else {
465                 $new_ifdef_state = "#ifdef PERL_CORE\n";
466             }
467
468             if ($new_ifdef_state ne $ifdef_state) {
469                 $ret = $new_ifdef_state . $ret;
470             }
471         }
472     }
473     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
474         # Close the old one ahead of opening the new one.
475         $ret = "#endif\n$ret";
476     }
477     # Remember the new state.
478     $ifdef_state = $new_ifdef_state;
479     $ret;
480 } $em;
481
482 if ($ifdef_state) {
483     print $em "#endif\n";
484 }
485
486 print $em <<'END';
487
488 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
489
490 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
491    disable them.
492  */
493
494 #if !defined(PERL_CORE)
495 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
496 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
497 #endif
498
499 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
500
501 /* Compatibility for various misnamed functions.  All functions
502    in the API that begin with "perl_" (not "Perl_") take an explicit
503    interpreter context pointer.
504    The following are not like that, but since they had a "perl_"
505    prefix in previous versions, we provide compatibility macros.
506  */
507 #  define perl_atexit(a,b)              call_atexit(a,b)
508 END
509
510 walk_table {
511     my ($flags,$retval,$func,@args) = @_;
512     return unless $func;
513     return unless $flags =~ /O/;
514
515     my $alist = join ",", @az[0..$#args];
516     my $ret = "#  define perl_$func($alist)";
517     my $t = (length $ret) >> 3;
518     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
519     "$ret$func($alist)\n";
520 } $em;
521
522 print $em <<'END';
523
524 /* varargs functions can't be handled with CPP macros. :-(
525    This provides a set of compatibility functions that don't take
526    an extra argument but grab the context pointer using the macro
527    dTHX.
528  */
529 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
530 END
531
532 foreach (sort keys %has_va) {
533     next unless $has_nocontext{$_};
534     next if /printf/; # Not clear to me why these are skipped but they are.
535     print $em hide($_, "Perl_${_}_nocontext", "  ");
536 }
537
538 print $em <<'END';
539 #endif
540
541 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
542
543 #if !defined(PERL_IMPLICIT_CONTEXT)
544 /* undefined symbols, point them back at the usual ones */
545 END
546
547 foreach (sort keys %has_va) {
548     next unless $has_nocontext{$_};
549     next if /printf/; # Not clear to me why these are skipped but they are.
550     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
551 }
552
553 print $em <<'END';
554 #endif
555
556 /* ex: set ro: */
557 END
558
559 safer_close($em);
560 rename_if_different('embed.h-new', 'embed.h');
561
562 $em = safer_open('embedvar.h-new');
563
564 print $em do_not_edit ("embedvar.h"), <<'END';
565
566 /* (Doing namespace management portably in C is really gross.) */
567
568 /*
569    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
570    are supported:
571      1) none
572      2) MULTIPLICITY    # supported for compatibility
573      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
574
575    All other combinations of these flags are errors.
576
577    only #3 is supported directly, while #2 is a special
578    case of #3 (supported by redefining vTHX appropriately).
579 */
580
581 #if defined(MULTIPLICITY)
582 /* cases 2 and 3 above */
583
584 #  if defined(PERL_IMPLICIT_CONTEXT)
585 #    define vTHX        aTHX
586 #  else
587 #    define vTHX        PERL_GET_INTERP
588 #  endif
589
590 END
591
592 for $sym (sort keys %intrp) {
593     print $em multon($sym,'I','vTHX->');
594 }
595
596 print $em <<'END';
597
598 #else   /* !MULTIPLICITY */
599
600 /* case 1 above */
601
602 END
603
604 for $sym (sort keys %intrp) {
605     print $em multoff($sym,'I');
606 }
607
608 print $em <<'END';
609
610 END
611
612 print $em <<'END';
613
614 #endif  /* MULTIPLICITY */
615
616 #if defined(PERL_GLOBAL_STRUCT)
617
618 END
619
620 for $sym (sort keys %globvar) {
621     print $em multon($sym,   'G','my_vars->');
622     print $em multon("G$sym",'', 'my_vars->');
623 }
624
625 print $em <<'END';
626
627 #else /* !PERL_GLOBAL_STRUCT */
628
629 END
630
631 for $sym (sort keys %globvar) {
632     print $em multoff($sym,'G');
633 }
634
635 print $em <<'END';
636
637 #endif /* PERL_GLOBAL_STRUCT */
638
639 /* ex: set ro: */
640 END
641
642 safer_close($em);
643 rename_if_different('embedvar.h-new', 'embedvar.h');
644
645 my $capi = safer_open('perlapi.c-new');
646 my $capih = safer_open('perlapi.h-new');
647
648 print $capih do_not_edit ("perlapi.h"), <<'EOT';
649
650 /* declare accessor functions for Perl variables */
651 #ifndef __perlapi_h__
652 #define __perlapi_h__
653
654 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
655
656 START_EXTERN_C
657
658 #undef PERLVAR
659 #undef PERLVARA
660 #undef PERLVARI
661 #undef PERLVARIC
662 #undef PERLVARISC
663 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
664 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
665                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
666 #define PERLVARI(v,t,i) PERLVAR(v,t)
667 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
668 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
669                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
670
671 #include "perlvars.h"
672
673 #undef PERLVAR
674 #undef PERLVARA
675 #undef PERLVARI
676 #undef PERLVARIC
677 #undef PERLVARISC
678
679 END_EXTERN_C
680
681 #if defined(PERL_CORE)
682
683 /* accessor functions for Perl "global" variables */
684
685 /* these need to be mentioned here, or most linkers won't put them in
686    the perl executable */
687
688 #ifndef PERL_NO_FORCE_LINK
689
690 START_EXTERN_C
691
692 #ifndef DOINIT
693 EXTCONST void * const PL_force_link_funcs[];
694 #else
695 EXTCONST void * const PL_force_link_funcs[] = {
696 #undef PERLVAR
697 #undef PERLVARA
698 #undef PERLVARI
699 #undef PERLVARIC
700 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
701 #define PERLVARA(v,n,t) PERLVAR(v,t)
702 #define PERLVARI(v,t,i) PERLVAR(v,t)
703 #define PERLVARIC(v,t,i) PERLVAR(v,t)
704 #define PERLVARISC(v,i) PERLVAR(v,char)
705
706 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
707  * cannot cast between void pointers and function pointers without
708  * info level warnings.  The PL_force_link_funcs[] would cause a few
709  * hundred of those warnings.  In code one can circumnavigate this by using
710  * unions that overlay the different pointers, but in declarations one
711  * cannot use this trick.  Therefore we just disable the warning here
712  * for the duration of the PL_force_link_funcs[] declaration. */
713
714 #if defined(__DECC) && defined(__osf__)
715 #pragma message save
716 #pragma message disable (nonstandcast)
717 #endif
718
719 #include "perlvars.h"
720
721 #if defined(__DECC) && defined(__osf__)
722 #pragma message restore
723 #endif
724
725 #undef PERLVAR
726 #undef PERLVARA
727 #undef PERLVARI
728 #undef PERLVARIC
729 #undef PERLVARISC
730 };
731 #endif  /* DOINIT */
732
733 END_EXTERN_C
734
735 #endif  /* PERL_NO_FORCE_LINK */
736
737 #else   /* !PERL_CORE */
738
739 EOT
740
741 foreach $sym (sort keys %globvar) {
742     print $capih bincompat_var('G',$sym);
743 }
744
745 print $capih <<'EOT';
746
747 #endif /* !PERL_CORE */
748 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
749
750 #endif /* __perlapi_h__ */
751
752 /* ex: set ro: */
753 EOT
754 safer_close($capih);
755 rename_if_different('perlapi.h-new', 'perlapi.h');
756
757 print $capi do_not_edit ("perlapi.c"), <<'EOT';
758
759 #include "EXTERN.h"
760 #include "perl.h"
761 #include "perlapi.h"
762
763 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
764
765 /* accessor functions for Perl "global" variables */
766 START_EXTERN_C
767
768 #undef PERLVARI
769 #define PERLVARI(v,t,i) PERLVAR(v,t)
770
771 #undef PERLVAR
772 #undef PERLVARA
773 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
774                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
775 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
776                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
777 #undef PERLVARIC
778 #undef PERLVARISC
779 #define PERLVARIC(v,t,i)        \
780                         const t* Perl_##v##_ptr(pTHX)           \
781                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
782 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
783                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
784 #include "perlvars.h"
785
786 #undef PERLVAR
787 #undef PERLVARA
788 #undef PERLVARI
789 #undef PERLVARIC
790 #undef PERLVARISC
791
792 END_EXTERN_C
793
794 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
795
796 /* ex: set ro: */
797 EOT
798
799 safer_close($capi);
800 rename_if_different('perlapi.c-new', 'perlapi.c');
801
802 # ex: set ts=8 sts=4 sw=4 noet: