X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=be381b9ce6bcd4e003ec0d7e1b546e9155c82037;hb=eb0f98c9231fa500029e4f3531ee246d1650a240;hp=320793d5570d0d5d14472522b0e45386f3f7717a;hpb=5a22a2bbf3880b61603040e7bdfddd4d5f5809a5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 320793d..be381b9 100644 --- a/perl.c +++ b/perl.c @@ -137,6 +137,22 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#define CALL_BODY_EVAL(myop) \ + if (PL_op == (myop)) \ + PL_op = Perl_pp_entereval(aTHX); \ + if (PL_op) \ + CALLRUNOPS(aTHX); + +#define CALL_BODY_SUB(myop) \ + if (PL_op == (myop)) \ + PL_op = Perl_pp_entersub(aTHX); \ + if (PL_op) \ + CALLRUNOPS(aTHX); + +#define CALL_LIST_BODY(cv) \ + PUSHMARK(PL_stack_sp); \ + call_sv((SV*)(cv), G_EVAL|G_DISCARD); + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -229,7 +245,7 @@ void perl_construct(pTHXx) { dVAR; - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -529,7 +545,7 @@ perl_destruct(pTHXx) pid_t child; #endif - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -1037,11 +1053,8 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; - if (!specialCopIO(PL_compiling.cop_io)) - SvREFCNT_dec(PL_compiling.cop_io); - PL_compiling.cop_io = NULL; - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints); - PL_compiling.cop_hints = NULL; + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); @@ -1441,7 +1454,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; - PERL_UNUSED_VAR(my_perl); + PERL_UNUSED_ARG(my_perl); #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -2281,7 +2294,7 @@ perl_run(pTHXx) int ret = 0; dJMPENV; - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); oldscope = PL_scopestack_ix; #ifdef VMS @@ -2609,7 +2622,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_EVAL)) { CATCH_SET(TRUE); - call_body((OP*)&myop, FALSE); + CALL_BODY_SUB((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); CATCH_SET(oldcatch); } @@ -2624,7 +2637,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - call_body((OP*)&myop, FALSE); + CALL_BODY_SUB((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpvn(ERRSV,"",0); @@ -2672,20 +2685,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) return retval; } -STATIC void -S_call_body(pTHX_ const OP *myop, bool is_eval) -{ - dVAR; - if (PL_op == myop) { - if (is_eval) - PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ - else - PL_op = Perl_pp_entersub(aTHX); /* this does */ - } - if (PL_op) - CALLRUNOPS(aTHX); -} - /* Eval a string. The G_EVAL flag is always assumed. */ /* @@ -2739,7 +2738,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - call_body((OP*)&myop,TRUE); + CALL_BODY_EVAL((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpvn(ERRSV,"",0); @@ -3263,8 +3262,8 @@ Perl_moreswitches(pTHX_ char *s) " DEVEL" STRINGIFY(PERL_PATCHNUM) #endif " built for %s", - vstringify(PL_patchlevel), - ARCHNAME)); + (void*)vstringify(PL_patchlevel), + ARCHNAME)); #else /* DGUX */ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ PerlIO_printf(PerlIO_stdout(), @@ -3283,7 +3282,7 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(), "\n(with %d registered patch%s, " "see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, + LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif @@ -3669,8 +3668,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, cpp, - cpp_discard_flag, sv, CPPMINUS); + perl, quote, code, quote, scriptname, (void*)cpp, + cpp_discard_flag, (void*)sv, CPPMINUS); PL_doextract = FALSE; @@ -5049,19 +5048,21 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, #endif /* .../version/archname if -d .../version/archname */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, - libdir, + (void*)libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, + (void*)libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, + (void*)libdir, ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); } @@ -5070,7 +5071,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver); subdir = S_incpush_if_exists(aTHX_ subdir); } } @@ -5124,7 +5125,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) if (PL_madskills) PL_madskills |= 16384; #endif - call_list_body(cv); + CALL_LIST_BODY(cv); #ifdef PERL_MAD if (PL_madskills) PL_madskills &= ~16384; @@ -5147,7 +5148,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%"SVf"", atsv); + Perl_croak(aTHX_ "%"SVf"", (void*)atsv); } break; case 1: @@ -5189,15 +5190,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) } } -STATIC void * -S_call_list_body(pTHX_ CV *cv) -{ - dVAR; - PUSHMARK(PL_stack_sp); - call_sv((SV*)cv, G_EVAL|G_DISCARD); - return NULL; -} - void Perl_my_exit(pTHX_ U32 status) {