diff options
Diffstat (limited to 'embed.pl')
| -rwxr-xr-x | embed.pl | 365 |
1 files changed, 36 insertions, 329 deletions
@@ -266,7 +266,7 @@ sub hide ($$) { sub bincompat_var ($$) { my ($pfx, $sym) = @_; - my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHXo'); + my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX'); undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))"); } @@ -331,7 +331,6 @@ print EM <<'END'; /* Hide global symbols */ -#if !defined(PERL_OBJECT) #if !defined(PERL_IMPLICIT_CONTEXT) END @@ -425,43 +424,11 @@ for $sym (sort keys %ppsym) { print EM <<'END'; #endif /* PERL_IMPLICIT_CONTEXT */ -#else /* PERL_OBJECT */ END -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) = @_; - if ($flags =~ /s/) { - $ret .= hide("S_$func","CPerlObj::S_$func") if $flags !~ /j/; - $ret .= hide($func,"S_$func"); - } - elsif ($flags =~ /p/) { - $ret .= hide("Perl_$func","CPerlObj::Perl_$func") if $flags !~ /j/; - $ret .= hide($func,"Perl_$func"); - } - else { - $ret .= hide($func,"CPerlObj::$func") if $flags !~ /j/; - } - } - $ret; -} \*EM; - -for $sym (sort keys %ppsym) { - $sym =~ s/^Perl_//; - print EM hide("Perl_$sym", "CPerlObj::Perl_$sym"); - print EM hide($sym, "Perl_$sym"); -} - print EM <<'END'; -#endif /* PERL_OBJECT */ - /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to disable them. */ @@ -502,7 +469,7 @@ print EM <<'END'; an extra argument but grab the context pointer using the macro dTHX. */ -#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_OBJECT) +#if defined(PERL_IMPLICIT_CONTEXT) # define croak Perl_croak_nocontext # define deb Perl_deb_nocontext # define die Perl_die_nocontext @@ -554,14 +521,13 @@ print EM <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* - The following combinations of MULTIPLICITY, USE_5005THREADS, PERL_OBJECT + 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 - 6) PERL_OBJECT && PERL_IMPLICIT_CONTEXT All other combinations of these flags are errors. @@ -586,10 +552,6 @@ for $sym (sort keys %thread) { print EM <<'END'; -# if defined(PERL_OBJECT) -# include "error: PERL_OBJECT + MULTIPLICITY don't go together" -# endif - # if defined(USE_5005THREADS) /* case 5 above */ @@ -616,24 +578,6 @@ print EM <<'END'; #else /* !MULTIPLICITY */ -# if defined(PERL_OBJECT) -/* case 6 above */ - -END - -for $sym (sort keys %thread) { - print EM multon($sym,'T','aTHXo->interp.'); -} - - -for $sym (sort keys %intrp) { - print EM multon($sym,'I','aTHXo->interp.'); -} - -print EM <<'END'; - -# else /* !PERL_OBJECT */ - /* cases 1 and 4 above */ END @@ -644,7 +588,7 @@ for $sym (sort keys %intrp) { print EM <<'END'; -# if defined(USE_5005THREADS) +# if defined(USE_5005THREADS) /* case 4 above */ END @@ -655,7 +599,7 @@ for $sym (sort keys %thread) { print EM <<'END'; -# else /* !USE_5005THREADS */ +# else /* !USE_5005THREADS */ /* case 1 above */ END @@ -666,8 +610,7 @@ for $sym (sort keys %thread) { print EM <<'END'; -# endif /* USE_5005THREADS */ -# endif /* PERL_OBJECT */ +# endif /* USE_5005THREADS */ #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) @@ -707,63 +650,6 @@ 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 data in embed.pl, pp.sym, intrpvar.h, - perlvars.h and thrdvar.h. Any changes made here will be lost! -*/ - -#ifndef __objXSUB_h__ -#define __objXSUB_h__ - -/* method calls via pPerl (static functions without a "this" pointer need these) */ - -#if defined(PERL_CORE) && defined(PERL_OBJECT) - -/* XXX soon to be eliminated, only a few things in PERLCORE need these now */ - -EOT - -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) = @_; - if ($flags =~ /A/ && $flags !~ /j/) { # API function needing macros - if ($flags =~ /p/) { - $ret .= undefine("Perl_$func") . hide("Perl_$func","pPerl->Perl_$func"); - $ret .= undefine($func) . hide($func,"Perl_$func"); - } - else { - $ret .= undefine($func) . hide($func,"pPerl->$func"); - } - } - } - $ret; -} \*OBX; - -# NOTE: not part of API -#for $sym (sort keys %ppsym) { -# $sym =~ s/^Perl_//; -# print OBX undefine("Perl_$sym") . hide("Perl_$sym", "pPerl->Perl_$sym"); -# print OBX undefine($sym) . hide($sym, "Perl_$sym"); -#} - -print OBX <<'EOT'; - -#endif /* PERL_CORE && PERL_OBJECT */ -#endif /* __objXSUB_h__ */ -EOT - -close(OBX); - unlink 'perlapi.h'; unlink 'perlapi.c'; open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n"; @@ -779,14 +665,7 @@ print CAPIH <<'EOT'; #ifndef __perlapi_h__ #define __perlapi_h__ -#if defined(PERL_OBJECT) || defined (MULTIPLICITY) - -#if defined(PERL_OBJECT) -# undef aTHXo -# define aTHXo pPerl -# undef aTHXo_ -# define aTHXo_ aTHXo, -#endif /* PERL_OBJECT */ +#if defined (MULTIPLICITY) START_EXTERN_C @@ -794,9 +673,9 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC -#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHXo); +#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(pTHXo); + 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) @@ -846,7 +725,7 @@ EXT void *PL_force_link_funcs[] = { }; #endif /* DOINIT */ -START_EXTERN_C +END_EXTERN_C #endif /* PERL_NO_FORCE_LINK */ @@ -869,7 +748,7 @@ foreach $sym (sort keys %globvar) { print CAPIH <<'EOT'; #endif /* !PERL_CORE */ -#endif /* PERL_OBJECT || MULTIPLICITY */ +#endif /* MULTIPLICITY */ #endif /* __perlapi_h__ */ @@ -886,7 +765,7 @@ print CAPI <<'EOT'; #include "perl.h" #include "perlapi.h" -#if defined(PERL_OBJECT) || defined (MULTIPLICITY) +#if defined (MULTIPLICITY) /* accessor functions for Perl variables (provides binary compatibility) */ START_EXTERN_C @@ -896,17 +775,10 @@ START_EXTERN_C #undef PERLVARI #undef PERLVARIC -#if defined(PERL_OBJECT) -#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->interp.v); } -#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->interp.v); } -#else /* MULTIPLICITY */ #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); } -#endif #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) @@ -916,12 +788,12 @@ START_EXTERN_C #undef PERLVAR #undef PERLVARA -#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \ +#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ { return &(PL_##v); } -#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ +#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(pTHXo) \ +#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \ { return (const t *)&(PL_##v); } #include "perlvars.h" @@ -930,14 +802,16 @@ START_EXTERN_C #undef PERLVARI #undef PERLVARIC -#if defined(PERL_OBJECT) - -/* C-API layer for PERL_OBJECT */ +END_EXTERN_C +#endif /* MULTIPLICITY */ EOT +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 @@ -956,138 +830,6 @@ my %vfuncs = qw( Perl_default_protect Perl_vdefault_protect ); -sub emit_func { - my ($addcontext, $rettype,$func,@args) = @_; - my @aargs = @args; - my $a; - for $a (@aargs) { $a =~ s/^.*\b(\w+)$/$1/ } - my $ctxarg = ''; - if (not $addcontext) { - $ctxarg = 'pTHXo'; - $ctxarg .= '_ ' if @args; - } - my $decl = ''; - if ($addcontext) { - $decl .= " dTHXo;\n"; - } - local $" = ', '; - my $return = ($rettype =~ /^\s*(void|Free_t|Signal_t)\s*$/ - ? '' : 'return '); - my $emitval = ''; - if (@args and $args[$#args] =~ /\.\.\./) { - pop @aargs; - my $retarg = ''; - my $ctxfunc = $func; - $ctxfunc =~ s/_nocontext$//; - return $emitval unless exists $vfuncs{$ctxfunc}; - if (length $return) { - $decl .= " $rettype retval;\n"; - $retarg .= "retval = "; - $return = "\n " . $return . "retval;\n"; - } - $emitval .= <<EOT -$rettype -$func($ctxarg@args) -{ -$decl va_list args; - va_start(args, $aargs[$#aargs]); - $retarg((CPerlObj*)pPerl)->$vfuncs{$ctxfunc}(@aargs, &args); - va_end(args);$return -} -EOT - } - else { - $emitval .= <<EOT -$rettype -$func($ctxarg@args) -{ -$decl $return((CPerlObj*)pPerl)->$func(@aargs); -} -EOT - } - $emitval; -} - -# XXXX temporary hack -for $sym (qw( - perl_construct - perl_destruct - perl_free - perl_run - perl_parse - )) -{ - $skipapi_funcs{$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) = @_; - return $ret if exists $skipapi_funcs{$func}; - if ($flags =~ /A/ && $flags !~ /j/) { # in public API, needed for XSUBS - $ret .= "\n"; - my $addctx = 1 if $flags =~ /n/; - if ($flags =~ /p/) { - $ret .= undefine("Perl_$func"); - $ret .= emit_func($addctx,$retval,"Perl_$func",@args); - } - else { - $ret .= undefine($func); - $ret .= emit_func($addctx,$retval,$func,@args); - } - } - } - $ret; -} \*CAPI; - -# NOTE: not part of the API -#for $sym (sort keys %ppsym) { -# $sym =~ s/^Perl_//; -# print CAPI "\n"; -# print CAPI undefine("Perl_$sym"); -# if ($sym =~ /^ck_/) { -# print CAPI emit_func(0, 'OP *',"Perl_$sym",'OP *o'); -# } -# else { # pp_foo -# print CAPI emit_func(0, 'OP *',"Perl_$sym"); -# } -#} - -print CAPI <<'EOT'; - -#undef Perl_fprintf_nocontext -int -Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) -{ - dTHXo; - va_list(arglist); - va_start(arglist, format); - return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist); -} - -#undef Perl_printf_nocontext -int -Perl_printf_nocontext(const char *format, ...) -{ - dTHXo; - va_list(arglist); - va_start(arglist, format); - return (*PL_StdIO->pVprintf)(PL_StdIO, PerlIO_stdout(), format, arglist); -} - -END_EXTERN_C - -#endif /* PERL_OBJECT */ -#endif /* PERL_OBJECT || MULTIPLICITY */ -EOT - -close(CAPI); - # autogenerate documentation from comments in source files my %apidocs; @@ -1318,7 +1060,6 @@ __END__ : f function takes printf style format string, varargs : r function never returns : o has no compatibility macro (#define foo Perl_foo) -: j not a member of CPerlObj : x not exported : M may change : @@ -1330,24 +1071,24 @@ __END__ START_EXTERN_C #if defined(PERL_IMPLICIT_SYS) -Ajno |PerlInterpreter* |perl_alloc_using \ +Ano |PerlInterpreter* |perl_alloc_using \ |struct IPerlMem* m|struct IPerlMem* ms \ |struct IPerlMem* mp|struct IPerlEnv* e \ |struct IPerlStdIO* io|struct IPerlLIO* lio \ |struct IPerlDir* d|struct IPerlSock* s \ |struct IPerlProc* p #endif -Ajnod |PerlInterpreter* |perl_alloc -Ajnod |void |perl_construct |PerlInterpreter* interp -Ajnod |int |perl_destruct |PerlInterpreter* interp -Ajnod |void |perl_free |PerlInterpreter* interp -Ajnod |int |perl_run |PerlInterpreter* interp -Ajnod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ +Anod |PerlInterpreter* |perl_alloc +Anod |void |perl_construct |PerlInterpreter* interp +Anod |int |perl_destruct |PerlInterpreter* interp +Anod |void |perl_free |PerlInterpreter* interp +Anod |int |perl_run |PerlInterpreter* interp +Anod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ |int argc|char** argv|char** env #if defined(USE_ITHREADS) -Ajnod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags +Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags # if defined(PERL_IMPLICIT_SYS) -Ajno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ +Ano |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ |struct IPerlMem* m|struct IPerlMem* ms \ |struct IPerlMem* mp|struct IPerlEnv* e \ |struct IPerlStdIO* io|struct IPerlLIO* lio \ @@ -1356,37 +1097,21 @@ Ajno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ # endif #endif -Ajnop |Malloc_t|malloc |MEM_SIZE nbytes -Ajnop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size -Ajnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes -Ajnop |Free_t |mfree |Malloc_t where +Anop |Malloc_t|malloc |MEM_SIZE nbytes +Anop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size +Anop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes +Anop |Free_t |mfree |Malloc_t where #if defined(MYMALLOC) -jnp |MEM_SIZE|malloced_size |void *p +np |MEM_SIZE|malloced_size |void *p #endif -Ajnp |void* |get_context -Ajnp |void |set_context |void *thx +Anp |void* |get_context +Anp |void |set_context |void *thx END_EXTERN_C /* functions with flag 'n' should come before here */ -#if defined(PERL_OBJECT) -class CPerlObj { -public: - struct interpreter interp; - CPerlObj(IPerlMem*, IPerlMem*, IPerlMem*, IPerlEnv*, IPerlStdIO*, - IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); - void* operator new(size_t nSize, IPerlMem *pvtbl); -#ifndef __BORLANDC__ - static void operator delete(void* pPerl, IPerlMem *pvtbl); -#endif - int do_aspawn (void *vreally, void **vmark, void **vsp); -#endif -#if defined(PERL_OBJECT) -public: -#else START_EXTERN_C -#endif # include "pp_proto.h" Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir Ap |bool |Gv_AMupdate |HV* stash @@ -1775,11 +1500,9 @@ Anp |I32 |my_memcmp |const char* s1|const char* s2|I32 len #if !defined(HAS_MEMSET) Anp |void* |my_memset |char* loc|I32 ch|I32 len #endif -#if !defined(PERL_OBJECT) Ap |I32 |my_pclose |PerlIO* ptr Ap |PerlIO*|my_popen |char* cmd|char* mode Ap |PerlIO*|my_popen_list |char* mode|int n|SV ** args -#endif Ap |void |my_setenv |char* nam|char* val Ap |I32 |my_stat Ap |char * |my_strftime |char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst @@ -1862,14 +1585,6 @@ p |void |pad_reset p |void |pad_swipe |PADOFFSET po p |void |peep |OP* o dopM |PerlIO*|start_glob |SV* pattern|IO *io -#if defined(PERL_OBJECT) -Aox |void |Perl_construct -Aox |void |Perl_destruct -Aox |void |Perl_free -Aox |int |Perl_run -Aox |int |Perl_parse |XSINIT_t xsinit \ - |int argc|char** argv|char** env -#endif #if defined(USE_5005THREADS) Ap |struct perl_thread* |new_struct_thread|struct perl_thread *t #endif @@ -2253,11 +1968,7 @@ Ap |char * |custom_op_name|OP* op Ap |char * |custom_op_desc|OP* op #endif -#if defined(PERL_OBJECT) -protected: -#else END_EXTERN_C -#endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) s |I32 |avhv_index_sv |SV* sv @@ -2614,10 +2325,6 @@ s |void |xstat |int # endif #endif -#if defined(PERL_OBJECT) -}; -#endif - START_EXTERN_C Apd |void |sv_setsv_flags |SV* dsv|SV* ssv|I32 flags |