3 require 5.003; # keep this compatible, an old perl is all we may have before
7 # See database of global and static function prototypes at the __END__.
8 # This is used to generate prototype headers under various configurations,
9 # export symbols lists for different platforms, and macros to provide an
10 # implicit interpreter context argument.
13 open IN, "embed.fnc" or die $!;
15 # walk table providing an array of components in each line to
16 # subroutine, printing the result
19 my $filename = shift || '-';
24 if (ref $filename) { # filehandle
29 open F, ">$filename" or die "Can't open $filename: $!";
32 print $F $leader if $leader;
33 seek IN, 0, 0; # so we may restart
46 @args = split /\s*\|\s*/, $_;
48 my @outs = &{$function}(@args);
49 print $F @outs; # $function->(@args) is not 5.003
51 print $F $trailer if $trailer;
52 close $F unless ref $filename;
55 sub munge_c_files () {
58 warn "\@ARGV empty, nothing to do\n";
63 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
68 # if (/^#\s*include\s+"perl.h"/) {
69 # my $file = uc $ARGV;
71 # print "#define PERL_IN_$file\n";
77 # if (exists $functions->{$f}) {
78 # my $flags = $functions->{$f}[0];
79 # $repl = "Perl_$repl" if $flags =~ /p/;
80 # unless ($flags =~ /n/) {
82 # $repl .= "_ " if @{$functions->{$f}} > 3;
84 # warn("$ARGV:$.:$repl\n");
88 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
92 if (exists $functions->{$f}) {
94 warn("$ARGV:$.:$`#$repl#$'");
99 close ARGV if eof; # restart $.
107 my $wrote_protected = 0;
116 my ($flags,$retval,$func,@args) = @_;
117 $ret .= '/* ' if $flags =~ /m/;
119 $retval = "STATIC $retval";
123 $retval = "PERL_CALLCONV $retval";
125 $func = "Perl_$func";
128 $ret .= "$retval\t$func(";
129 unless ($flags =~ /n/) {
131 $ret .= "_ " if @args;
134 $ret .= join ", ", @args;
137 $ret .= "void" if $flags =~ /n/;
140 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
141 if( $flags =~ /f/ ) {
142 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
143 my $args = scalar @args;
144 $ret .= "\n#ifdef CHECK_FORMAT\n";
145 $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
146 $prefix, $args - 1, $prefix, $args;
147 $ret .= "\n#endif\n";
150 $ret .= ' */' if $flags =~ /m/;
156 # generates global.sym (API export list), and populates %global with global symbols
157 sub write_global_sym {
160 my ($flags,$retval,$func,@args) = @_;
161 if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
162 $func = "Perl_$func" if $flags =~ /p/;
170 walk_table(\&write_protos, 'proto.h', <<'EOT');
172 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
173 * This file is autogenerated from data in embed.pl. Edit that file
174 * and run 'make regen_headers' to effect changes.
179 walk_table(\&write_global_sym, 'global.sym', <<'EOT');
181 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
182 # This file is autogenerated from data in embed.pl. Edit that file
183 # and run 'make regen_headers' to effect changes.
188 # XXX others that may need adding
192 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
194 tainting tainted stack_base stack_sp sv_arenaroot
196 curstash DBsub DBsingle debstash
210 my ($syms, $file) = @_;
212 open(FILE, "< $file")
213 or die "embed.pl: Can't open $file: $!\n";
215 s/[ \t]*#.*//; # Delete comments.
216 if (/^\s*(\S+)\s*$/) {
218 warn "duplicate symbol $sym while processing $file\n"
219 if exists $$syms{$sym};
226 # Perl_pp_* and Perl_ck_* are in pp.sym
227 readsyms my %ppsym, 'pp.sym';
229 sub readvars(\%$$@) {
230 my ($syms, $file,$pre,$keep_pre) = @_;
232 open(FILE, "< $file")
233 or die "embed.pl: Can't open $file: $!\n";
235 s/[ \t]*#.*//; # Delete comments.
236 if (/PERLVARA?I?C?\($pre(\w+)/) {
238 $sym = $pre . $sym if $keep_pre;
239 warn "duplicate symbol $sym while processing $file\n"
240 if exists $$syms{$sym};
241 $$syms{$sym} = $pre || 1;
250 readvars %intrp, 'intrpvar.h','I';
251 readvars %thread, 'thrdvar.h','T';
252 readvars %globvar, 'perlvars.h','G';
255 foreach $sym (sort keys %thread) {
256 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
265 my ($from, $to) = @_;
266 my $t = int(length($from) / 8);
267 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
270 sub bincompat_var ($$) {
271 my ($pfx, $sym) = @_;
272 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
273 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
277 my ($sym,$pre,$ptr) = @_;
278 hide("PL_$sym", "($ptr$pre$sym)");
283 return hide("PL_$pre$sym", "PL_$sym");
287 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
290 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
291 This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
292 perlvars.h and thrdvar.h. Any changes made here will be lost!
295 /* (Doing namespace management portably in C is really gross.) */
297 /* NO_EMBED is no longer supported. i.e. EMBED is always active. */
299 /* provide binary compatible (but inconsistent) names */
300 #if defined(PERL_BINCOMPAT_5005)
301 # define Perl_call_atexit perl_atexit
302 # define Perl_eval_sv perl_eval_sv
303 # define Perl_eval_pv perl_eval_pv
304 # define Perl_call_argv perl_call_argv
305 # define Perl_call_method perl_call_method
306 # define Perl_call_pv perl_call_pv
307 # define Perl_call_sv perl_call_sv
308 # define Perl_get_av perl_get_av
309 # define Perl_get_cv perl_get_cv
310 # define Perl_get_hv perl_get_hv
311 # define Perl_get_sv perl_get_sv
312 # define Perl_init_i18nl10n perl_init_i18nl10n
313 # define Perl_init_i18nl14n perl_init_i18nl14n
314 # define Perl_new_collate perl_new_collate
315 # define Perl_new_ctype perl_new_ctype
316 # define Perl_new_numeric perl_new_numeric
317 # define Perl_require_pv perl_require_pv
318 # define Perl_safesyscalloc Perl_safecalloc
319 # define Perl_safesysfree Perl_safefree
320 # define Perl_safesysmalloc Perl_safemalloc
321 # define Perl_safesysrealloc Perl_saferealloc
322 # define Perl_set_numeric_local perl_set_numeric_local
323 # define Perl_set_numeric_standard perl_set_numeric_standard
324 /* malloc() pollution was the default in earlier versions, so enable
325 * it for bincompat; but not for systems that used to do prevent that,
326 * or when they ask for {HIDE,EMBED}MYMALLOC */
327 # if !defined(EMBEDMYMALLOC) && !defined(HIDEMYMALLOC)
328 # if !defined(NeXT) && !defined(__NeXT) && !defined(__MACHTEN__) && \
330 # define PERL_POLLUTE_MALLOC
335 /* Hide global symbols */
337 #if !defined(PERL_IMPLICIT_CONTEXT)
345 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
348 my ($flags,$retval,$func,@args) = @_;
349 unless ($flags =~ /[om]/) {
351 $ret .= hide($func,"S_$func");
353 elsif ($flags =~ /p/) {
354 $ret .= hide($func,"Perl_$func");
361 for $sym (sort keys %ppsym) {
363 print EM hide($sym, "Perl_$sym");
368 #else /* PERL_IMPLICIT_CONTEXT */
378 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
381 my ($flags,$retval,$func,@args) = @_;
382 unless ($flags =~ /[om]/) {
383 my $args = scalar @args;
384 if ($args and $args[$args-1] =~ /\.\.\./) {
385 # we're out of luck for varargs functions under CPP
387 elsif ($flags =~ /n/) {
389 $ret .= hide($func,"S_$func");
391 elsif ($flags =~ /p/) {
392 $ret .= hide($func,"Perl_$func");
396 my $alist = join(",", @az[0..$args-1]);
397 $ret = "#define $func($alist)";
398 my $t = int(length($ret) / 8);
399 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
401 $ret .= "S_$func(aTHX";
403 elsif ($flags =~ /p/) {
404 $ret .= "Perl_$func(aTHX";
406 $ret .= "_ " if $alist;
407 $ret .= $alist . ")\n";
414 for $sym (sort keys %ppsym) {
416 if ($sym =~ /^ck_/) {
417 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
419 elsif ($sym =~ /^pp_/) {
420 print EM hide("$sym()", "Perl_$sym(aTHX)");
423 warn "Illegal symbol '$sym' in pp.sym";
429 #endif /* PERL_IMPLICIT_CONTEXT */
435 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
439 #if !defined(PERL_CORE)
440 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
441 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
444 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) && !defined(PERL_BINCOMPAT_5005)
446 /* Compatibility for various misnamed functions. All functions
447 in the API that begin with "perl_" (not "Perl_") take an explicit
448 interpreter context pointer.
449 The following are not like that, but since they had a "perl_"
450 prefix in previous versions, we provide compatibility macros.
452 # define perl_atexit(a,b) call_atexit(a,b)
453 # define perl_call_argv(a,b,c) call_argv(a,b,c)
454 # define perl_call_pv(a,b) call_pv(a,b)
455 # define perl_call_method(a,b) call_method(a,b)
456 # define perl_call_sv(a,b) call_sv(a,b)
457 # define perl_eval_sv(a,b) eval_sv(a,b)
458 # define perl_eval_pv(a,b) eval_pv(a,b)
459 # define perl_require_pv(a) require_pv(a)
460 # define perl_get_sv(a,b) get_sv(a,b)
461 # define perl_get_av(a,b) get_av(a,b)
462 # define perl_get_hv(a,b) get_hv(a,b)
463 # define perl_get_cv(a,b) get_cv(a,b)
464 # define perl_init_i18nl10n(a) init_i18nl10n(a)
465 # define perl_init_i18nl14n(a) init_i18nl14n(a)
466 # define perl_new_ctype(a) new_ctype(a)
467 # define perl_new_collate(a) new_collate(a)
468 # define perl_new_numeric(a) new_numeric(a)
470 /* varargs functions can't be handled with CPP macros. :-(
471 This provides a set of compatibility functions that don't take
472 an extra argument but grab the context pointer using the macro
475 #if defined(PERL_IMPLICIT_CONTEXT)
476 # define croak Perl_croak_nocontext
477 # define deb Perl_deb_nocontext
478 # define die Perl_die_nocontext
479 # define form Perl_form_nocontext
480 # define load_module Perl_load_module_nocontext
481 # define mess Perl_mess_nocontext
482 # define newSVpvf Perl_newSVpvf_nocontext
483 # define sv_catpvf Perl_sv_catpvf_nocontext
484 # define sv_setpvf Perl_sv_setpvf_nocontext
485 # define warn Perl_warn_nocontext
486 # define warner Perl_warner_nocontext
487 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
488 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
491 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
493 #if !defined(PERL_IMPLICIT_CONTEXT)
494 /* undefined symbols, point them back at the usual ones */
495 # define Perl_croak_nocontext Perl_croak
496 # define Perl_die_nocontext Perl_die
497 # define Perl_deb_nocontext Perl_deb
498 # define Perl_form_nocontext Perl_form
499 # define Perl_load_module_nocontext Perl_load_module
500 # define Perl_mess_nocontext Perl_mess
501 # define Perl_newSVpvf_nocontext Perl_newSVpvf
502 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
503 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
504 # define Perl_warn_nocontext Perl_warn
505 # define Perl_warner_nocontext Perl_warner
506 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
507 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
515 open(EM, '> embedvar.h')
516 or die "Can't create embedvar.h: $!\n";
519 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
520 This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
521 perlvars.h and thrdvar.h. Any changes made here will be lost!
524 /* (Doing namespace management portably in C is really gross.) */
527 The following combinations of MULTIPLICITY, USE_5005THREADS
528 and PERL_IMPLICIT_CONTEXT are supported:
530 2) MULTIPLICITY # supported for compatibility
531 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
532 4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
533 5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
535 All other combinations of these flags are errors.
537 #3, #4, #5, and #6 are supported directly, while #2 is a special
538 case of #3 (supported by redefining vTHX appropriately).
541 #if defined(MULTIPLICITY)
542 /* cases 2, 3 and 5 above */
544 # if defined(PERL_IMPLICIT_CONTEXT)
547 # define vTHX PERL_GET_INTERP
552 for $sym (sort keys %thread) {
553 print EM multon($sym,'T','vTHX->');
558 # if defined(USE_5005THREADS)
563 for $sym (sort keys %intrp) {
564 print EM multon($sym,'I','PERL_GET_INTERP->');
569 # else /* !USE_5005THREADS */
570 /* cases 2 and 3 above */
574 for $sym (sort keys %intrp) {
575 print EM multon($sym,'I','vTHX->');
580 # endif /* USE_5005THREADS */
582 #else /* !MULTIPLICITY */
584 /* cases 1 and 4 above */
588 for $sym (sort keys %intrp) {
589 print EM multoff($sym,'I');
594 # if defined(USE_5005THREADS)
599 for $sym (sort keys %thread) {
600 print EM multon($sym,'T','aTHX->');
605 # else /* !USE_5005THREADS */
610 for $sym (sort keys %thread) {
611 print EM multoff($sym,'T');
616 # endif /* USE_5005THREADS */
617 #endif /* MULTIPLICITY */
619 #if defined(PERL_GLOBAL_STRUCT)
623 for $sym (sort keys %globvar) {
624 print EM multon($sym,'G','PL_Vars.');
629 #else /* !PERL_GLOBAL_STRUCT */
633 for $sym (sort keys %globvar) {
634 print EM multoff($sym,'G');
639 #endif /* PERL_GLOBAL_STRUCT */
641 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
645 for $sym (sort @extvars) {
646 print EM hide($sym,"PL_$sym");
651 #endif /* PERL_POLLUTE */
658 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
659 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
662 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
663 This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
664 perlvars.h and thrdvar.h. Any changes made here will be lost!
667 /* declare accessor functions for Perl variables */
668 #ifndef __perlapi_h__
669 #define __perlapi_h__
671 #if defined (MULTIPLICITY)
679 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
680 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
681 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
682 #define PERLVARI(v,t,i) PERLVAR(v,t)
683 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
686 #include "intrpvar.h"
687 #include "perlvars.h"
696 #if defined(PERL_CORE)
698 /* accessor functions for Perl variables (provide binary compatibility) */
700 /* these need to be mentioned here, or most linkers won't put them in
701 the perl executable */
703 #ifndef PERL_NO_FORCE_LINK
708 EXT void *PL_force_link_funcs[];
710 EXT void *PL_force_link_funcs[] = {
715 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
716 #define PERLVARA(v,n,t) PERLVAR(v,t)
717 #define PERLVARI(v,t,i) PERLVAR(v,t)
718 #define PERLVARIC(v,t,i) PERLVAR(v,t)
721 #include "intrpvar.h"
722 #include "perlvars.h"
733 #endif /* PERL_NO_FORCE_LINK */
735 #else /* !PERL_CORE */
739 foreach $sym (sort keys %intrp) {
740 print CAPIH bincompat_var('I',$sym);
743 foreach $sym (sort keys %thread) {
744 print CAPIH bincompat_var('T',$sym);
747 foreach $sym (sort keys %globvar) {
748 print CAPIH bincompat_var('G',$sym);
753 #endif /* !PERL_CORE */
754 #endif /* MULTIPLICITY */
756 #endif /* __perlapi_h__ */
762 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
763 This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
764 perlvars.h and thrdvar.h. Any changes made here will be lost!
771 #if defined (MULTIPLICITY)
773 /* accessor functions for Perl variables (provides binary compatibility) */
781 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
782 { return &(aTHX->v); }
783 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
784 { return &(aTHX->v); }
786 #define PERLVARI(v,t,i) PERLVAR(v,t)
787 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
790 #include "intrpvar.h"
794 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
795 { return &(PL_##v); }
796 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
797 { return &(PL_##v); }
799 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
800 { return (const t *)&(PL_##v); }
801 #include "perlvars.h"
810 #endif /* MULTIPLICITY */
815 # functions that take va_list* for implementing vararg functions
816 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
817 # XXX %vfuncs currently unused
819 Perl_croak Perl_vcroak
821 Perl_warner Perl_vwarner
824 Perl_load_module Perl_vload_module
827 Perl_newSVpvf Perl_vnewSVpvf
828 Perl_sv_setpvf Perl_sv_vsetpvf
829 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
830 Perl_sv_catpvf Perl_sv_vcatpvf
831 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
832 Perl_dump_indent Perl_dump_vindent
833 Perl_default_protect Perl_vdefault_protect