#!/usr/bin/perl -w
-require 5.003;
+require 5.003; # keep this compatible, an old perl is all we may have before
+ # we build the new one
+
+#
+# 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.
+#
+
+open IN, "embed.fnc" or die $!;
+
+# walk table providing an array of components in each line to
+# subroutine, printing the result
+sub walk_table (&@) {
+ my $function = shift;
+ my $filename = shift || '-';
+ my $leader = shift;
+ my $trailer = shift;
+ my $F;
+ local *F;
+ if (ref $filename) { # filehandle
+ $F = $filename;
+ }
+ else {
+ unlink $filename;
+ open F, ">$filename" or die "Can't open $filename: $!";
+ $F = \*F;
+ }
+ print $F $leader if $leader;
+ seek IN, 0, 0; # so we may restart
+ while (<IN>) {
+ chomp;
+ next if /^:/;
+ while (s|\\$||) {
+ $_ .= <IN>;
+ chomp;
+ }
+ my @args;
+ if (/^\s*(#|$)/) {
+ @args = $_;
+ }
+ else {
+ @args = split /\s*\|\s*/, $_;
+ }
+ my @outs = &{$function}(@args);
+ print $F @outs; # $function->(@args) is not 5.003
+ }
+ print $F $trailer if $trailer;
+ close $F unless ref $filename;
+}
+
+sub munge_c_files () {
+ my $functions = {};
+ unless (@ARGV) {
+ warn "\@ARGV empty, nothing to do\n";
+ return;
+ }
+ walk_table {
+ if (@_ > 1) {
+ $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
+ }
+ } '/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;
+ my $f = $2;
+ if (exists $functions->{$f}) {
+ $repl .= "aTHX_ ";
+ warn("$ARGV:$.:$`#$repl#$'");
+ }
+ $repl;
+ }eg;
+ print;
+ close ARGV if eof; # restart $.
+ }
+ exit;
+}
+
+#munge_c_files();
+
+# generate proto.h
+my $wrote_protected = 0;
+
+sub write_protos {
+ my $ret = "";
+ if (@_ == 1) {
+ my $arg = shift;
+ $ret .= "$arg\n";
+ }
+ else {
+ my ($flags,$retval,$func,@args) = @_;
+ $ret .= '/* ' if $flags =~ /m/;
+ if ($flags =~ /s/) {
+ $retval = "STATIC $retval";
+ $func = "S_$func";
+ }
+ else {
+ $retval = "PERL_CALLCONV $retval";
+ if ($flags =~ /p/) {
+ $func = "Perl_$func";
+ }
+ }
+ $ret .= "$retval\t$func(";
+ unless ($flags =~ /n/) {
+ $ret .= "pTHX";
+ $ret .= "_ " if @args;
+ }
+ if (@args) {
+ $ret .= join ", ", @args;
+ }
+ else {
+ $ret .= "void" if $flags =~ /n/;
+ }
+ $ret .= ")";
+ $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
+ if( $flags =~ /f/ ) {
+ my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
+ my $args = scalar @args;
+ $ret .= "\n#ifdef CHECK_FORMAT\n";
+ $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
+ $prefix, $args - 1, $prefix, $args;
+ $ret .= "\n#endif\n";
+ }
+ $ret .= ";";
+ $ret .= ' */' if $flags =~ /m/;
+ $ret .= "\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;
+}
+
+
+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
# XXX others that may need adding
# warnhook
# hints
# copline
my @extvars = qw(sv_undef sv_yes sv_no na dowarn
- curcop compiling
+ curcop compiling
tainting tainted stack_base stack_sp sv_arenaroot
no_modify
curstash DBsub DBsingle debstash
- rsfp
+ rsfp
stdingv
defgv
errgv
diehook
dirty
perl_destruct_level
+ ppaddr
);
sub readsyms (\%$) {
close(FILE);
}
-readsyms %global, 'global.sym';
-readsyms %global, 'pp.sym';
+# Perl_pp_* and Perl_ck_* are in pp.sym
+readsyms my %ppsym, 'pp.sym';
sub readvars(\%$$@) {
my ($syms, $file,$pre,$keep_pre) = @_;
or die "embed.pl: Can't open $file: $!\n";
while (<FILE>) {
s/[ \t]*#.*//; # Delete comments.
- if (/PERLVARI?C?\($pre(\w+)/) {
+ if (/PERLVARA?I?C?\($pre(\w+)/) {
my $sym = $1;
$sym = $pre . $sym if $keep_pre;
warn "duplicate symbol $sym while processing $file\n"
if exists $$syms{$sym};
- $$syms{$sym} = 1;
+ $$syms{$sym} = $pre || 1;
}
}
close(FILE);
readvars %intrp, 'intrpvar.h','I';
readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';
-readvars %objvar, 'intrpvar.h','pi', 1;
-
-foreach my $sym (sort keys %intrp)
- {
- if (exists $global{$sym})
- {
- delete $global{$sym};
- warn "$sym in {global,pp}.sym as well as intrpvar.h\n";
- }
- }
-
-foreach my $sym (sort keys %globvar)
- {
- if (exists $global{$sym})
- {
- delete $global{$sym};
- warn "$sym in {global,pp}.sym as well as perlvars.h\n";
- }
- }
-
-foreach my $sym (sort keys %thread)
- {
+
+my $sym;
+foreach $sym (sort keys %thread) {
warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
- if (exists $global{$sym})
- {
- delete $global{$sym};
- warn "$sym in {global,pp}.sym as well as thrdvar.h\n";
- }
- }
+}
sub undefine ($) {
my ($sym) = @_;
"#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
}
-sub embed ($) {
- my ($sym) = @_;
- hide($sym, "Perl_$sym");
-}
-
-sub embedobj ($) {
- my ($sym) = @_;
- hide($sym, $sym =~ /^perl_/i ? "CPerlObj::$sym" : "CPerlObj::Perl_$sym");
-}
-
-sub objxsub_func ($) {
- my ($sym) = @_;
- undefine($sym) . hide($sym, $sym =~ /^perl_/i
- ? "pPerl->$sym"
- : "pPerl->Perl_$sym");
-}
-
-sub objxsub_var ($) {
- my ($sym) = @_;
- undefine("PL_$sym") . hide("PL_$sym", "pPerl->PL_$sym");
-}
-
-sub embedvar ($) {
- my ($sym) = @_;
-# hide($sym, "Perl_$sym");
- return '';
+sub bincompat_var ($$) {
+ my ($pfx, $sym) = @_;
+ my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
+ undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
}
sub multon ($$$) {
my ($sym,$pre,$ptr) = @_;
hide("PL_$sym", "($ptr$pre$sym)");
}
+
sub multoff ($$) {
my ($sym,$pre) = @_;
return hide("PL_$pre$sym", "PL_$sym");
}
unlink 'embed.h';
-open(EM, '> embed.h')
- or die "Can't create embed.h: $!\n";
+open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
print EM <<'END';
-/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
- perlvars.h and thrdvar.h. Any changes made here will be lost!
-*/
+/*
+ * 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!
+ */
/* (Doing namespace management portably in C is really gross.) */
/* Hide global symbols */
-#if !defined(PERL_OBJECT)
+#if !defined(PERL_IMPLICIT_CONTEXT)
END
-for $sym (sort keys %global) {
- print EM embed($sym);
+walk_table {
+ my $ret = "";
+ if (@_ == 1) {
+ my $arg = shift;
+ $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
+ }
+ else {
+ my ($flags,$retval,$func,@args) = @_;
+ unless ($flags =~ /[om]/) {
+ if ($flags =~ /s/) {
+ $ret .= hide($func,"S_$func");
+ }
+ elsif ($flags =~ /p/) {
+ $ret .= hide($func,"Perl_$func");
+ }
+ }
+ }
+ $ret;
+} \*EM;
+
+for $sym (sort keys %ppsym) {
+ $sym =~ s/^Perl_//;
+ print EM hide($sym, "Perl_$sym");
}
print EM <<'END';
-#else /* PERL_OBJECT */
+#else /* PERL_IMPLICIT_CONTEXT */
END
-# XXX these should be in a *.sym file
-my @staticfuncs = qw(
- perl_init_i18nl10n
- perl_init_i18nl14n
- perl_new_collate
- perl_new_ctype
- perl_new_numeric
- perl_set_numeric_local
- perl_set_numeric_standard
- perl_construct
- perl_destruct
- perl_atexit
- perl_free
- perl_parse
- perl_run
- perl_get_sv
- perl_get_av
- perl_get_hv
- perl_get_cv
- perl_call_argv
- perl_call_pv
- perl_call_method
- perl_call_sv
- perl_eval_pv
- perl_eval_sv
- perl_require_pv
-
- hsplit
- hfreeentries
- more_he
- new_he
- del_he
- save_hek
- mess_alloc
- gv_init_sv
- save_scalar_at
- asIV
- asUV
- more_sv
- more_xiv
- more_xnv
- more_xpv
- more_xrv
- new_xiv
- new_xnv
- new_xpv
- new_xrv
- del_xiv
- del_xnv
- del_xpv
- del_xrv
- sv_unglob
- avhv_index_sv
- do_report_used
- do_clean_objs
- do_clean_named_objs
- do_clean_all
- not_a_number
- my_safemalloc
- visit
- qsortsv
- sortcv
- save_magic
- magic_methpack
- magic_methcall
- magic_methcall
- doform
- doencodes
- refto
- seed
- docatch
- docatch_body
- perl_parse_body
- perl_run_body
- perl_call_body
- perl_call_xbody
- call_list_body
- dofindlabel
- doparseform
- dopoptoeval
- dopoptolabel
- dopoptoloop
- dopoptosub
- dopoptosub_at
- free_closures
- save_lines
- doeval
- doopen_pmc
- sv_ncmp
- sv_i_ncmp
- amagic_ncmp
- amagic_i_ncmp
- amagic_cmp
- amagic_cmp_locale
- mul128
- is_an_int
- div128
- runops_standard
- runops_debug
- check_uni
- force_next
- force_version
- force_word
- tokeq
- scan_const
- scan_formline
- scan_heredoc
- scan_ident
- scan_inputsymbol
- scan_pat
- scan_str
- scan_subst
- scan_trans
- scan_word
- skipspace
- checkcomma
- force_ident
- incline
- intuit_method
- intuit_more
- lop
- missingterm
- no_op
- set_csh
- sublex_done
- sublex_push
- sublex_start
- uni
- filter_gets
- new_constant
- ao
- depcom
- win32_textfilter
- incl_perldb
- isa_lookup
- get_db_sub
- list_assignment
- bad_type
- modkids
- no_fh_allowed
- no_bareword_allowed
- scalarboolean
- too_few_arguments
- too_many_arguments
- null
- pad_findlex
- newDEFSVOP
- gv_ename
- cv_clone2
- find_beginning
- forbid_setid
- incpush
- init_interp
- init_ids
- init_debugger
- init_lexer
- init_main_stash
- init_perllib
- init_postdump_symbols
- init_predump_symbols
- my_exit_jump
- nuke_stacks
- open_script
- usage
- validate_suid
- emulate_eaccess
- reg
- reganode
- regatom
- regbranch
- regc
- reguni
- regclass
- regclassutf8
- regcurly
- reg_node
- regpiece
- reginsert
- regoptail
- regset
- regtail
- regwhite
- nextchar
- dumpuntil
- scan_commit
- study_chunk
- add_data
- re_croak2
- regpposixcc
- clear_re
- regmatch
- regrepeat
- regrepeat_hard
- regtry
- reginclass
- reginclassutf8
- regcppush
- regcppop
- regcp_set_to
- cache_re
- restore_pos
- reghop
- reghopmaybe
- dump
- do_aspawn
- debprof
- new_logop
- simplify_sort
- is_handle_constructor
- sv_add_backref
- sv_del_backref
- do_trans_CC_simple
- do_trans_CC_count
- do_trans_CC_complex
- do_trans_UU_simple
- do_trans_UU_count
- do_trans_UU_complex
- do_trans_UC_simple
- do_trans_CU_simple
- do_trans_UC_trivial
- do_trans_CU_trivial
- unwind_handler_stack
- restore_magic
- restore_rsfp
- restore_expect
- restore_lex_expect
- yydestruct
- del_sv
- fprintf
-);
+my @az = ('a'..'z');
+
+walk_table {
+ my $ret = "";
+ if (@_ == 1) {
+ my $arg = shift;
+ $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
+ }
+ else {
+ my ($flags,$retval,$func,@args) = @_;
+ unless ($flags =~ /[om]/) {
+ my $args = scalar @args;
+ if ($args and $args[$args-1] =~ /\.\.\./) {
+ # we're out of luck for varargs functions under CPP
+ }
+ elsif ($flags =~ /n/) {
+ if ($flags =~ /s/) {
+ $ret .= hide($func,"S_$func");
+ }
+ elsif ($flags =~ /p/) {
+ $ret .= hide($func,"Perl_$func");
+ }
+ }
+ else {
+ my $alist = join(",", @az[0..$args-1]);
+ $ret = "#define $func($alist)";
+ my $t = int(length($ret) / 8);
+ $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
+ if ($flags =~ /s/) {
+ $ret .= "S_$func(aTHX";
+ }
+ elsif ($flags =~ /p/) {
+ $ret .= "Perl_$func(aTHX";
+ }
+ $ret .= "_ " if $alist;
+ $ret .= $alist . ")\n";
+ }
+ }
+ }
+ $ret;
+} \*EM;
-for $sym (sort(keys(%global),@staticfuncs)) {
- print EM embedobj($sym);
+for $sym (sort keys %ppsym) {
+ $sym =~ s/^Perl_//;
+ if ($sym =~ /^ck_/) {
+ print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
+ }
+ elsif ($sym =~ /^pp_/) {
+ print EM hide("$sym()", "Perl_$sym(aTHX)");
+ }
+ else {
+ warn "Illegal symbol '$sym' in pp.sym";
+ }
}
print EM <<'END';
-#endif /* PERL_OBJECT */
+#endif /* PERL_IMPLICIT_CONTEXT */
-/* compatibility stubs */
+END
+
+print EM <<'END';
-#define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,(IV)ptr)
-#define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,(IV)ptr)
+/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
+ disable them.
+ */
+
+#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))
+#endif
+
+#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
+ interpreter context pointer.
+ The following are not like that, but since they had a "perl_"
+ prefix in previous versions, we provide compatibility macros.
+ */
+# define perl_atexit(a,b) call_atexit(a,b)
+# define perl_call_argv(a,b,c) call_argv(a,b,c)
+# define perl_call_pv(a,b) call_pv(a,b)
+# define perl_call_method(a,b) call_method(a,b)
+# define perl_call_sv(a,b) call_sv(a,b)
+# define perl_eval_sv(a,b) eval_sv(a,b)
+# define perl_eval_pv(a,b) eval_pv(a,b)
+# define perl_require_pv(a) require_pv(a)
+# define perl_get_sv(a,b) get_sv(a,b)
+# define perl_get_av(a,b) get_av(a,b)
+# define perl_get_hv(a,b) get_hv(a,b)
+# define perl_get_cv(a,b) get_cv(a,b)
+# define perl_init_i18nl10n(a) init_i18nl10n(a)
+# define perl_init_i18nl14n(a) init_i18nl14n(a)
+# define perl_new_ctype(a) new_ctype(a)
+# define perl_new_collate(a) new_collate(a)
+# define perl_new_numeric(a) new_numeric(a)
+
+/* varargs functions can't be handled with CPP macros. :-(
+ This provides a set of compatibility functions that don't take
+ an extra argument but grab the context pointer using the macro
+ dTHX.
+ */
+#if defined(PERL_IMPLICIT_CONTEXT)
+# define croak Perl_croak_nocontext
+# define deb Perl_deb_nocontext
+# define die Perl_die_nocontext
+# define form Perl_form_nocontext
+# define load_module Perl_load_module_nocontext
+# define mess Perl_mess_nocontext
+# define newSVpvf Perl_newSVpvf_nocontext
+# define sv_catpvf Perl_sv_catpvf_nocontext
+# define sv_setpvf Perl_sv_setpvf_nocontext
+# define warn Perl_warn_nocontext
+# define warner Perl_warner_nocontext
+# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
+# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
+#endif
+
+#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
+
+#if !defined(PERL_IMPLICIT_CONTEXT)
+/* undefined symbols, point them back at the usual ones */
+# define Perl_croak_nocontext Perl_croak
+# define Perl_die_nocontext Perl_die
+# define Perl_deb_nocontext Perl_deb
+# define Perl_form_nocontext Perl_form
+# define Perl_load_module_nocontext Perl_load_module
+# define Perl_mess_nocontext Perl_mess
+# define Perl_newSVpvf_nocontext Perl_newSVpvf
+# define Perl_sv_catpvf_nocontext Perl_sv_catpvf
+# define Perl_sv_setpvf_nocontext Perl_sv_setpvf
+# define Perl_warn_nocontext Perl_warn
+# define Perl_warner_nocontext Perl_warner
+# define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
+# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
+#endif
END
or die "Can't create embedvar.h: $!\n";
print EM <<'END';
-/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
- perlvars.h and thrdvar.h. Any changes made here will be lost!
-*/
+/*
+ * 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!
+ */
/* (Doing namespace management portably in C is really gross.) */
-/* Put interpreter-specific symbols into a struct? */
+/*
+ The following combinations of MULTIPLICITY, USE_5005THREADS
+ 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
+ case of #3 (supported by redefining vTHX appropriately).
+*/
-#ifdef MULTIPLICITY
+#if defined(MULTIPLICITY)
+/* cases 2, 3 and 5 above */
-#ifndef USE_THREADS
-/* If we do not have threads then per-thread vars are per-interpreter */
+# if defined(PERL_IMPLICIT_CONTEXT)
+# define vTHX aTHX
+# else
+# define vTHX PERL_GET_INTERP
+# endif
END
for $sym (sort keys %thread) {
- print EM multon($sym,'T','PL_curinterp->');
+ print EM multon($sym,'T','vTHX->');
}
print EM <<'END';
-#endif /* !USE_THREADS */
-
-/* These are always per-interpreter if there is more than one */
+# if defined(USE_5005THREADS)
+/* case 5 above */
END
for $sym (sort keys %intrp) {
- print EM multon($sym,'I','PL_curinterp->');
+ print EM multon($sym,'I','PERL_GET_INTERP->');
}
print EM <<'END';
-#else /* !MULTIPLICITY */
+# else /* !USE_5005THREADS */
+/* cases 2 and 3 above */
END
for $sym (sort keys %intrp) {
- print EM multoff($sym,'I');
+ print EM multon($sym,'I','vTHX->');
}
print EM <<'END';
-#ifndef USE_THREADS
-
-END
-
-for $sym (sort keys %thread) {
- print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+# endif /* USE_5005THREADS */
-#endif /* USE_THREADS */
+#else /* !MULTIPLICITY */
-/* Hide what would have been interpreter-specific symbols? */
+/* cases 1 and 4 above */
END
for $sym (sort keys %intrp) {
- print EM embedvar($sym);
+ print EM multoff($sym,'I');
}
print EM <<'END';
-#ifndef USE_THREADS
+# if defined(USE_5005THREADS)
+/* case 4 above */
END
for $sym (sort keys %thread) {
- print EM embedvar($sym);
+ print EM multon($sym,'T','aTHX->');
}
print EM <<'END';
-#endif /* USE_THREADS */
-#endif /* MULTIPLICITY */
-
-/* Now same trickey for per-thread variables */
-
-#ifdef USE_THREADS
+# else /* !USE_5005THREADS */
+/* case 1 above */
END
for $sym (sort keys %thread) {
- print EM multon($sym,'T','thr->');
+ print EM multoff($sym,'T');
}
print EM <<'END';
-#endif /* USE_THREADS */
+# endif /* USE_5005THREADS */
+#endif /* MULTIPLICITY */
-#ifdef PERL_GLOBAL_STRUCT
+#if defined(PERL_GLOBAL_STRUCT)
END
print EM <<'END';
-END
-
-for $sym (sort keys %globvar) {
- print EM embedvar($sym);
-}
-
-print EM <<'END';
-
#endif /* PERL_GLOBAL_STRUCT */
-END
-
-print EM <<'END';
-
-#ifdef PERL_POLLUTE /* disabled by default in 5.006 */
+#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
END
#endif /* PERL_POLLUTE */
END
-
close(EM);
-unlink 'objXSUB.h';
-open(OBX, '> objXSUB.h')
- or die "Can't create objXSUB.h: $!\n";
-
-print OBX <<'EOT';
-/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
- perlvars.h and thrdvar.h. Any changes made here will be lost!
-*/
-
-#ifndef __objXSUB_h__
-#define __objXSUB_h__
-
-/* Variables */
+unlink 'perlapi.h';
+unlink 'perlapi.c';
+open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
+open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
+
+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!
+ */
+
+/* declare accessor functions for Perl variables */
+#ifndef __perlapi_h__
+#define __perlapi_h__
+
+#if defined (MULTIPLICITY)
+
+START_EXTERN_C
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#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)
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+END_EXTERN_C
+
+#if defined(PERL_CORE)
+
+/* accessor functions for Perl variables (provide binary compatibility) */
+
+/* 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
+EXT void *PL_force_link_funcs[];
+#else
+EXT void *PL_force_link_funcs[] = {
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
+#define PERLVARA(v,n,t) PERLVAR(v,t)
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v,t)
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+};
+#endif /* DOINIT */
+
+END_EXTERN_C
+
+#endif /* PERL_NO_FORCE_LINK */
+
+#else /* !PERL_CORE */
EOT
-foreach my $sym (sort(keys(%intrp),
- keys(%thread),
- keys(%globvar),
- keys(%objvar)))
-{
- print OBX objxsub_var($sym);
+foreach $sym (sort keys %intrp) {
+ print CAPIH bincompat_var('I',$sym);
}
-print OBX <<'EOT';
-
-/* Functions */
+foreach $sym (sort keys %thread) {
+ print CAPIH bincompat_var('T',$sym);
+}
-EOT
+foreach $sym (sort keys %globvar) {
+ print CAPIH bincompat_var('G',$sym);
+}
+print CAPIH <<'EOT';
-for $sym (sort(keys(%global),@staticfuncs)) {
- print OBX objxsub_func($sym);
-}
+#endif /* !PERL_CORE */
+#endif /* MULTIPLICITY */
+#endif /* __perlapi_h__ */
-print OBX <<'EOT';
+EOT
+close 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!
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perlapi.h"
+
+#if defined (MULTIPLICITY)
+
+/* accessor functions for Perl variables (provides binary compatibility) */
+START_EXTERN_C
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
+ { return &(aTHX->v); }
+#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
+ { return &(aTHX->v); }
+
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v, const t)
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
+ { return &(PL_##v); }
+#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
+ { return &(PL_##v); }
+#undef PERLVARIC
+#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
+ { return (const t *)&(PL_##v); }
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+END_EXTERN_C
-#endif /* __objXSUB_h__ */
+#endif /* MULTIPLICITY */
EOT
-close(OBX);
+close(CAPI);
+
+# functions that take va_list* for implementing vararg functions
+# NOTE: makedef.pl must be updated if you add symbols to %vfuncs
+# XXX %vfuncs currently unused
+my %vfuncs = qw(
+ Perl_croak Perl_vcroak
+ Perl_warn Perl_vwarn
+ Perl_warner Perl_vwarner
+ Perl_die Perl_vdie
+ Perl_form Perl_vform
+ Perl_load_module Perl_vload_module
+ Perl_mess Perl_vmess
+ Perl_deb Perl_vdeb
+ Perl_newSVpvf Perl_vnewSVpvf
+ Perl_sv_setpvf Perl_sv_vsetpvf
+ Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
+ Perl_sv_catpvf Perl_sv_vcatpvf
+ Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
+ Perl_dump_indent Perl_dump_vindent
+ Perl_default_protect Perl_vdefault_protect
+);
projects / p5sagit/p5-mst-13.2.git / blobdiff