This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make change#3386 a build-time option (avoids problems due to
authorGurusamy Sarathy <gsar@cpan.org>
Sun, 20 Feb 2000 16:07:38 +0000 (16:07 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Sun, 20 Feb 2000 16:07:38 +0000 (16:07 +0000)
perl_run() longjmping out)

p4raw-link: @3386 on //depot/perl: 312caa8e97f1c7ee342a9895c2f0e749625b4929

p4raw-id: //depot/perl@5162

16 files changed:
Todo-5.6
embed.h
embed.pl
intrpvar.h
objXSUB.h
perl.c
perl.h
perlapi.c
perlvars.h
pp_ctl.c
proto.h
scope.c
scope.h
sv.c
thrdvar.h
util.c

index 28b146d..8ae31ad 100644 (file)
--- a/Todo-5.6
+++ b/Todo-5.6
@@ -1,5 +1,4 @@
 Bugs
-    perl_run() can longjmp out
     fix small memory leaks on compile-time failures
 
 Unicode support
diff --git a/embed.h b/embed.h
index be6a685..ea76f70 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define do_pmop_dump           Perl_do_pmop_dump
 #define do_sv_dump             Perl_do_sv_dump
 #define magic_dump             Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 #define default_protect                Perl_default_protect
 #define vdefault_protect       Perl_vdefault_protect
+#endif
 #define reginitcolors          Perl_reginitcolors
 #define sv_2pv_nolen           Perl_sv_2pv_nolen
 #define sv_2pvutf8_nolen       Perl_sv_2pvutf8_nolen
 #define parse_body             S_parse_body
 #define run_body               S_run_body
 #define call_body              S_call_body
-#define call_xbody             S_call_xbody
 #define call_list_body         S_call_list_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vparse_body            S_vparse_body
+#define vrun_body              S_vrun_body
+#define vcall_body             S_vcall_body
+#define vcall_list_body                S_vcall_list_body
+#endif
 #  if defined(USE_THREADS)
 #define init_main_thread       S_init_main_thread
 #  endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
 #define docatch                        S_docatch
 #define docatch_body           S_docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vdocatch_body          S_vdocatch_body
+#endif
 #define dofindlabel            S_dofindlabel
 #define doparseform            S_doparseform
 #define dopoptoeval            S_dopoptoeval
 #define do_pmop_dump(a,b,c)    Perl_do_pmop_dump(aTHX_ a,b,c)
 #define do_sv_dump(a,b,c,d,e,f,g)      Perl_do_sv_dump(aTHX_ a,b,c,d,e,f,g)
 #define magic_dump(a)          Perl_magic_dump(aTHX_ a)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 #define vdefault_protect(a,b,c,d)      Perl_vdefault_protect(aTHX_ a,b,c,d)
+#endif
 #define reginitcolors()                Perl_reginitcolors(aTHX)
 #define sv_2pv_nolen(a)                Perl_sv_2pv_nolen(aTHX_ a)
 #define sv_2pvutf8_nolen(a)    Perl_sv_2pvutf8_nolen(aTHX_ a)
 #  if defined(IAMSUID)
 #define fd_on_nosuid_fs(a)     S_fd_on_nosuid_fs(aTHX_ a)
 #  endif
-#define parse_body(a)          S_parse_body(aTHX_ a)
+#define parse_body(a,b)                S_parse_body(aTHX_ a,b)
 #define run_body(a)            S_run_body(aTHX_ a)
-#define call_body(a)           S_call_body(aTHX_ a)
-#define call_xbody(a,b)                S_call_xbody(aTHX_ a,b)
+#define call_body(a,b)         S_call_body(aTHX_ a,b)
 #define call_list_body(a)      S_call_list_body(aTHX_ a)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vparse_body(a)         S_vparse_body(aTHX_ a)
+#define vrun_body(a)           S_vrun_body(aTHX_ a)
+#define vcall_body(a)          S_vcall_body(aTHX_ a)
+#define vcall_list_body(a)     S_vcall_list_body(aTHX_ a)
+#endif
 #  if defined(USE_THREADS)
 #define init_main_thread()     S_init_main_thread(aTHX)
 #  endif
 #endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
 #define docatch(a)             S_docatch(aTHX_ a)
-#define docatch_body(a)                S_docatch_body(aTHX_ a)
+#define docatch_body()         S_docatch_body(aTHX)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vdocatch_body(a)       S_vdocatch_body(aTHX_ a)
+#endif
 #define dofindlabel(a,b,c,d)   S_dofindlabel(aTHX_ a,b,c,d)
 #define doparseform(a)         S_doparseform(aTHX_ a)
 #define dopoptoeval(a)         S_dopoptoeval(aTHX_ a)
 #define do_sv_dump             Perl_do_sv_dump
 #define Perl_magic_dump                CPerlObj::Perl_magic_dump
 #define magic_dump             Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 #define Perl_default_protect   CPerlObj::Perl_default_protect
 #define default_protect                Perl_default_protect
 #define Perl_vdefault_protect  CPerlObj::Perl_vdefault_protect
 #define vdefault_protect       Perl_vdefault_protect
+#endif
 #define Perl_reginitcolors     CPerlObj::Perl_reginitcolors
 #define reginitcolors          Perl_reginitcolors
 #define Perl_sv_2pv_nolen      CPerlObj::Perl_sv_2pv_nolen
 #define run_body               S_run_body
 #define S_call_body            CPerlObj::S_call_body
 #define call_body              S_call_body
-#define S_call_xbody           CPerlObj::S_call_xbody
-#define call_xbody             S_call_xbody
 #define S_call_list_body       CPerlObj::S_call_list_body
 #define call_list_body         S_call_list_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define S_vparse_body          CPerlObj::S_vparse_body
+#define vparse_body            S_vparse_body
+#define S_vrun_body            CPerlObj::S_vrun_body
+#define vrun_body              S_vrun_body
+#define S_vcall_body           CPerlObj::S_vcall_body
+#define vcall_body             S_vcall_body
+#define S_vcall_list_body      CPerlObj::S_vcall_list_body
+#define vcall_list_body                S_vcall_list_body
+#endif
 #  if defined(USE_THREADS)
 #define S_init_main_thread     CPerlObj::S_init_main_thread
 #define init_main_thread       S_init_main_thread
 #define docatch                        S_docatch
 #define S_docatch_body         CPerlObj::S_docatch_body
 #define docatch_body           S_docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define S_vdocatch_body                CPerlObj::S_vdocatch_body
+#define vdocatch_body          S_vdocatch_body
+#endif
 #define S_dofindlabel          CPerlObj::S_dofindlabel
 #define dofindlabel            S_dofindlabel
 #define S_doparseform          CPerlObj::S_doparseform
index 3366a24..c1967d2 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2097,10 +2097,12 @@ Ap      |void   |do_pmop_dump   |I32 level|PerlIO *file|PMOP *pm
 Ap     |void   |do_sv_dump     |I32 level|PerlIO *file|SV *sv|I32 nest \
                                |I32 maxnest|bool dumpops|STRLEN pvlim
 Ap     |void   |magic_dump     |MAGIC *mg
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 Ap     |void*  |default_protect|volatile JMPENV *je|int *excpt \
                                |protect_body_t body|...
 Ap     |void*  |vdefault_protect|volatile JMPENV *je|int *excpt \
                                |protect_body_t body|va_list *args
+#endif
 Ap     |void   |reginitcolors
 Ap     |char*  |sv_2pv_nolen   |SV* sv
 Ap     |char*  |sv_2pvutf8_nolen|SV* sv
@@ -2237,11 +2239,16 @@ s       |void   |validate_suid  |char *|char*|int
 #  if defined(IAMSUID)
 s      |int    |fd_on_nosuid_fs|int fd
 #  endif
-s      |void*  |parse_body     |va_list args
-s      |void*  |run_body       |va_list args
-s      |void*  |call_body      |va_list args
-s      |void   |call_xbody     |OP *myop|int is_eval
-s      |void*  |call_list_body |va_list args
+s      |void*  |parse_body     |char **env|XSINIT_t xsinit
+s      |void*  |run_body       |I32 oldscope
+s      |void   |call_body      |OP *myop|int is_eval
+s      |void*  |call_list_body |CV *cv
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+s      |void*  |vparse_body    |va_list args
+s      |void*  |vrun_body      |va_list args
+s      |void*  |vcall_body     |va_list args
+s      |void*  |vcall_list_body|va_list args
+#endif
 #  if defined(USE_THREADS)
 s      |struct perl_thread *   |init_main_thread
 #  endif
@@ -2258,7 +2265,10 @@ s        |int    |div128         |SV *pnum|bool *done
 
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
 s      |OP*    |docatch        |OP *o
-s      |void*  |docatch_body   |va_list args
+s      |void*  |docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+s      |void*  |vdocatch_body  |va_list args
+#endif
 s      |OP*    |dofindlabel    |OP *o|char *label|OP **opstack|OP **oplimit
 s      |void   |doparseform    |SV *sv
 s      |I32    |dopoptoeval    |I32 startingblock
index e578b1a..1403787 100644 (file)
@@ -8,10 +8,7 @@
  * generated when built with or without MULTIPLICITY.  It is also used
  * to generate the appropriate export list for win32.
  *
- * When building without MULTIPLICITY, these variables will be truly global.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING.  That way,
- * we can keep binary compatibility of the curinterp structure */
+ * When building without MULTIPLICITY, these variables will be truly global. */
 
 /* pseudo environmental stuff */
 PERLVAR(Iorigargc,     int)
index 2897a6a..c2385f8 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_magic_dump                pPerl->Perl_magic_dump
 #undef  magic_dump
 #define magic_dump             Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 #undef  Perl_default_protect
 #define Perl_default_protect   pPerl->Perl_default_protect
 #undef  default_protect
 #define Perl_vdefault_protect  pPerl->Perl_vdefault_protect
 #undef  vdefault_protect
 #define vdefault_protect       Perl_vdefault_protect
+#endif
 #undef  Perl_reginitcolors
 #define Perl_reginitcolors     pPerl->Perl_reginitcolors
 #undef  reginitcolors
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #  if defined(IAMSUID)
 #  endif
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
 #  if defined(USE_THREADS)
 #  endif
 #endif
 #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
 #endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
 #endif
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 #endif
diff --git a/perl.c b/perl.c
index 6776ac9..eba7e5c 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -155,7 +155,9 @@ perl_construct(pTHXx)
        thr = init_main_thread();
 #endif /* USE_THREADS */
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
        PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
+#endif
 
        PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 
@@ -800,13 +802,20 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
-               env, xsinit);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
+#else
+    JMPENV_PUSH(ret);
+#endif
     switch (ret) {
     case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+       parse_body(env,xsinit);
+#endif
        if (PL_checkav)
            call_list(oldscope, PL_checkav);
-       return 0;
+       ret = 0;
+       break;
     case 1:
        STATUS_ALL_FAILURE;
        /* FALL THROUGH */
@@ -818,21 +827,34 @@ setuid perl scripts securely.\n");
        PL_curstash = PL_defstash;
        if (PL_checkav)
            call_list(oldscope, PL_checkav);
-       return STATUS_NATIVE_EXPORT;
+       ret = STATUS_NATIVE_EXPORT;
+       break;
     case 3:
        PerlIO_printf(Perl_error_log, "panic: top_env\n");
-       return 1;
+       ret = 1;
+       break;
     }
-    return 0;
+    JMPENV_POP;
+    return ret;
+}
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+STATIC void *
+S_vparse_body(pTHX_ va_list args)
+{
+    char **env = va_arg(args, char**);
+    XSINIT_t xsinit = va_arg(args, XSINIT_t);
+
+    return parse_body(env, xsinit);
 }
+#endif
 
 STATIC void *
-S_parse_body(pTHX_ va_list args)
+S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 {
     dTHR;
     int argc = PL_origargc;
     char **argv = PL_origargv;
-    char **env = va_arg(args, char**);
     char *scriptname = NULL;
     int fdscript = -1;
     VOL bool dosearch = FALSE;
@@ -842,8 +864,6 @@ S_parse_body(pTHX_ va_list args)
     register char *s;
     char *cddir = Nullch;
 
-    XSINIT_t xsinit = va_arg(args, XSINIT_t);
-
     sv_setpvn(PL_linestr,"",0);
     sv = newSVpvn("",0);               /* first used for -I flags */
     SAVEFREESV(sv);
@@ -1230,7 +1250,7 @@ perl_run(pTHXx)
 {
     dTHR;
     I32 oldscope;
-    int ret;
+    int ret = 0;
     dJMPENV;
 #ifdef USE_THREADS
     dTHX;
@@ -1238,14 +1258,23 @@ perl_run(pTHXx)
 
     oldscope = PL_scopestack_ix;
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
-    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
+#else
+    JMPENV_PUSH(ret);
+#endif
     switch (ret) {
     case 1:
        cxstack_ix = -1;                /* start context stack again */
        goto redo_body;
-    case 0:  /* normal completion */
-    case 2:  /* my_exit() */
+    case 0:                            /* normal completion */
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+       run_body(oldscope);
+#endif
+       /* FALL THROUGH */
+    case 2:                            /* my_exit() */
        while (PL_scopestack_ix > oldscope)
            LEAVE;
        FREETMPS;
@@ -1256,7 +1285,8 @@ perl_run(pTHXx)
        if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
            dump_mstats("after execution:  ");
 #endif
-       return STATUS_NATIVE_EXPORT;
+       ret = STATUS_NATIVE_EXPORT;
+       break;
     case 3:
        if (PL_restartop) {
            POPSTACK_TO(PL_mainstack);
@@ -1264,19 +1294,30 @@ perl_run(pTHXx)
        }
        PerlIO_printf(Perl_error_log, "panic: restartop\n");
        FREETMPS;
-       return 1;
+       ret = 1;
+       break;
     }
 
-    /* NOTREACHED */
-    return 0;
+    JMPENV_POP;
+    return ret;
 }
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 STATIC void *
-S_run_body(pTHX_ va_list args)
+S_vrun_body(pTHX_ va_list args)
 {
-    dTHR;
     I32 oldscope = va_arg(args, I32);
 
+    return run_body(oldscope);
+}
+#endif
+
+
+STATIC void *
+S_run_body(pTHX_ I32 oldscope)
+{
+    dTHR;
+
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
                     PL_sawampersand ? "Enabling" : "Omitting"));
 
@@ -1543,7 +1584,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 
     if (!(flags & G_EVAL)) {
        CATCH_SET(TRUE);
-       call_xbody((OP*)&myop, FALSE);
+       call_body((OP*)&myop, FALSE);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        CATCH_SET(oldcatch);
     }
@@ -1571,11 +1612,19 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        }
        PL_markstack_ptr++;
 
-  redo_body:
-       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
                    (OP*)&myop, FALSE);
+#else
+       JMPENV_PUSH(ret);
+#endif
        switch (ret) {
        case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+           call_body((OP*)&myop, FALSE);
+#endif
            retval = PL_stack_sp - (PL_stack_base + oldmark);
            if (!(flags & G_KEEPERR))
                sv_setpv(ERRSV,"");
@@ -1587,6 +1636,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
            /* my_exit() was called */
            PL_curstash = PL_defstash;
            FREETMPS;
+           JMPENV_POP;
            if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
                Perl_croak(aTHX_ "Callback called exit");
            my_exit_jump();
@@ -1620,6 +1670,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
            PL_curpm = newpm;
            LEAVE;
        }
+       JMPENV_POP;
     }
 
     if (flags & G_DISCARD) {
@@ -1632,18 +1683,20 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     return retval;
 }
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 STATIC void *
-S_call_body(pTHX_ va_list args)
+S_vcall_body(pTHX_ va_list args)
 {
     OP *myop = va_arg(args, OP*);
     int is_eval = va_arg(args, int);
 
-    call_xbody(myop, is_eval);
+    call_body(myop, is_eval);
     return NULL;
 }
+#endif
 
 STATIC void
-S_call_xbody(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ OP *myop, int is_eval)
 {
     dTHR;
 
@@ -1703,11 +1756,19 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     if (flags & G_KEEPERR)
        myop.op_flags |= OPf_SPECIAL;
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
-    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
                (OP*)&myop, TRUE);
+#else
+    JMPENV_PUSH(ret);
+#endif
     switch (ret) {
     case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+       call_body((OP*)&myop,TRUE);
+#endif
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        if (!(flags & G_KEEPERR))
            sv_setpv(ERRSV,"");
@@ -1719,6 +1780,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        /* my_exit() was called */
        PL_curstash = PL_defstash;
        FREETMPS;
+       JMPENV_POP;
        if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
            Perl_croak(aTHX_ "Callback called exit");
        my_exit_jump();
@@ -1739,6 +1801,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        break;
     }
 
+    JMPENV_POP;
     if (flags & G_DISCARD) {
        PL_stack_sp = PL_stack_base + oldmark;
        retval = 0;
@@ -3373,9 +3436,16 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     while (AvFILL(paramList) >= 0) {
        cv = (CV*)av_shift(paramList);
        SAVEFREESV(cv);
-       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
+#else
+       JMPENV_PUSH(ret);
+#endif
        switch (ret) {
        case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+           call_list_body(cv);
+#endif
            atsv = ERRSV;
            (void)SvPV(atsv, len);
            if (len) {
@@ -3392,6 +3462,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                                   : "END");
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
+               JMPENV_POP;
                Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
            }
            break;
@@ -3406,6 +3477,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            PL_curstash = PL_defstash;
            PL_curcop = &PL_compiling;
            CopLINE_set(PL_curcop, oldline);
+           JMPENV_POP;
            if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
                if (paramList == PL_beginav)
                    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
@@ -3427,15 +3499,22 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            FREETMPS;
            break;
        }
+       JMPENV_POP;
     }
 }
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 STATIC void *
-S_call_list_body(pTHX_ va_list args)
+S_vcall_list_body(pTHX_ va_list args)
 {
-    dTHR;
     CV *cv = va_arg(args, CV*);
+    return call_list_body(cv);
+}
+#endif
 
+STATIC void *
+S_call_list_body(pTHX_ CV *cv)
+{
     PUSHMARK(PL_stack_sp);
     call_sv((SV*)cv, G_EVAL|G_DISCARD);
     return NULL;
diff --git a/perl.h b/perl.h
index 66162e6..cdf1ecd 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -215,7 +215,10 @@ struct perl_thread;
 #define CALLREG_INTUIT_START CALL_FPTR(PL_regint_start)
 #define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string)
 #define CALLREGFREE CALL_FPTR(PL_regfree)
-#define CALLPROTECT CALL_FPTR(PL_protect)
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+#  define CALLPROTECT CALL_FPTR(PL_protect)
+#endif
 
 #define NOOP (void)0
 #define dNOOP extern int Perl___notused
index f082498..c4653cc 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3589,6 +3589,7 @@ Perl_magic_dump(pTHXo_ MAGIC *mg)
 {
     ((CPerlObj*)pPerl)->Perl_magic_dump(mg);
 }
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 
 #undef  Perl_default_protect
 void*
@@ -3609,6 +3610,7 @@ Perl_vdefault_protect(pTHXo_ volatile JMPENV *je, int *excpt, protect_body_t bod
 {
     return ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, args);
 }
+#endif
 
 #undef  Perl_reginitcolors
 void
@@ -3864,12 +3866,16 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl)
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #  if defined(IAMSUID)
 #  endif
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
 #  if defined(USE_THREADS)
 #  endif
 #endif
 #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
 #endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
 #endif
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 #endif
index 55769d5..220574a 100644 (file)
  *
  * The 'G' prefix is only needed for vars that need appropriate #defines
  * generated in embed*.h.  Such symbols are also used to generate
- * the appropriate export list for win32.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING.  That way,
- * we can keep binary compatibility of the curinterp structure */
-
+ * the appropriate export list for win32. */
 
 /* global state */
 PERLVAR(Gcurinterp,    PerlInterpreter *)
index 030bcbd..24fad37 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2521,9 +2521,17 @@ S_save_lines(pTHX_ AV *array, SV *sv)
     }
 }
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 STATIC void *
 S_docatch_body(pTHX_ va_list args)
 {
+    return docatch_body();
+}
+#endif
+
+STATIC void *
+S_docatch_body(pTHX)
+{
     CALLRUNOPS(aTHX);
     return NULL;
 }
@@ -2541,10 +2549,18 @@ S_docatch(pTHX_ OP *o)
     assert(CATCH_GET == TRUE);
 #endif
     PL_op = o;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
+#else
+    JMPENV_PUSH(ret);
+#endif
     switch (ret) {
     case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+       docatch_body();
+#endif
        break;
     case 3:
        if (PL_restartop && cursi == PL_curstackinfo) {
@@ -2554,10 +2570,12 @@ S_docatch(pTHX_ OP *o)
        }
        /* FALL THROUGH */
     default:
+       JMPENV_POP;
        PL_op = oldop;
        JMPENV_JUMP(ret);
        /* NOTREACHED */
     }
+    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
diff --git a/proto.h b/proto.h
index 31b8f45..d4e218f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -876,8 +876,10 @@ PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o);
 PERL_CALLCONV void     Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm);
 PERL_CALLCONV void     Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim);
 PERL_CALLCONV void     Perl_magic_dump(pTHX_ MAGIC *mg);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 PERL_CALLCONV void*    Perl_default_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, ...);
 PERL_CALLCONV void*    Perl_vdefault_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args);
+#endif
 PERL_CALLCONV void     Perl_reginitcolors(pTHX);
 PERL_CALLCONV char*    Perl_sv_2pv_nolen(pTHX_ SV* sv);
 PERL_CALLCONV char*    Perl_sv_2pvutf8_nolen(pTHX_ SV* sv);
@@ -1011,11 +1013,16 @@ STATIC void     S_validate_suid(pTHX_ char *, char*, int);
 #  if defined(IAMSUID)
 STATIC int     S_fd_on_nosuid_fs(pTHX_ int fd);
 #  endif
-STATIC void*   S_parse_body(pTHX_ va_list args);
-STATIC void*   S_run_body(pTHX_ va_list args);
-STATIC void*   S_call_body(pTHX_ va_list args);
-STATIC void    S_call_xbody(pTHX_ OP *myop, int is_eval);
-STATIC void*   S_call_list_body(pTHX_ va_list args);
+STATIC void*   S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
+STATIC void*   S_run_body(pTHX_ I32 oldscope);
+STATIC void    S_call_body(pTHX_ OP *myop, int is_eval);
+STATIC void*   S_call_list_body(pTHX_ CV *cv);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+STATIC void*   S_vparse_body(pTHX_ va_list args);
+STATIC void*   S_vrun_body(pTHX_ va_list args);
+STATIC void*   S_vcall_body(pTHX_ va_list args);
+STATIC void*   S_vcall_list_body(pTHX_ va_list args);
+#endif
 #  if defined(USE_THREADS)
 STATIC struct perl_thread *    S_init_main_thread(pTHX);
 #  endif
@@ -1032,7 +1039,10 @@ STATIC int       S_div128(pTHX_ SV *pnum, bool *done);
 
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
 STATIC OP*     S_docatch(pTHX_ OP *o);
-STATIC void*   S_docatch_body(pTHX_ va_list args);
+STATIC void*   S_docatch_body(pTHX);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+STATIC void*   S_vdocatch_body(pTHX_ va_list args);
+#endif
 STATIC OP*     S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit);
 STATIC void    S_doparseform(pTHX_ SV *sv);
 STATIC I32     S_dopoptoeval(pTHX_ I32 startingblock);
diff --git a/scope.c b/scope.c
index e6c3125..740000a 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -16,6 +16,7 @@
 #define PERL_IN_SCOPE_C
 #include "perl.h"
 
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
 void *
 Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
                     protect_body_t body, ...)
@@ -36,8 +37,6 @@ Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
     int ex;
     void *ret;
 
-    DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n",
-               pcur_env, PL_top_env));
     JMPENV_PUSH(ex);
     if (ex)
        ret = NULL;
@@ -47,6 +46,7 @@ Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
     JMPENV_POP;
     return ret;
 }
+#endif
 
 SV**
 Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
diff --git a/scope.h b/scope.h
index fa21199..f33154a 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -193,19 +193,21 @@ struct jmpenv {
     Sigjmp_buf         je_buf;         /* only for use if !je_throw */
     int                        je_ret;         /* last exception thrown */
     bool               je_mustcatch;   /* need to call longjmp()? */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
     void               (*je_throw)(int v); /* last for bincompat */
     bool               je_noset;       /* no need for setjmp() */
+#endif
 };
 
 typedef struct jmpenv JMPENV;
 
-/*
- * Function that catches/throws, and its callback for the
- *  body of protected processing.
- */
-typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
-typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
-                                            int *, protect_body_t, ...);
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM  PL_opsave = op
+#define OP_MEM_TO_REG  op = PL_opsave
+#else
+#define OP_REG_TO_MEM  NOOP
+#define OP_MEM_TO_REG  NOOP
+#endif
 
 /*
  * How to build the first jmpenv.
@@ -219,21 +221,13 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
 
 #define JMPENV_BOOTSTRAP \
     STMT_START {                               \
-       PL_start_env.je_prev = NULL;            \
-       PL_start_env.je_throw = NULL;           \
+       Zero(&PL_start_env, 1, JMPENV);         \
        PL_start_env.je_ret = -1;               \
        PL_start_env.je_mustcatch = TRUE;       \
-       PL_start_env.je_noset = 0;              \
        PL_top_env = &PL_start_env;             \
     } STMT_END
 
-#ifdef OP_IN_REGISTER
-#define OP_REG_TO_MEM  PL_opsave = op
-#define OP_MEM_TO_REG  op = PL_opsave
-#else
-#define OP_REG_TO_MEM  NOOP
-#define OP_MEM_TO_REG  NOOP
-#endif
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 
 /*
  * These exception-handling macros are split up to
@@ -265,6 +259,14 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
  *    JMPENV_POP;  // don't forget this!
  */
 
+/*
+ * Function that catches/throws, and its callback for the
+ *  body of protected processing.
+ */
+typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
+typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
+                                            int *, protect_body_t, ...);
+
 #define dJMPENV        JMPENV cur_env; \
                volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env)
 
@@ -288,10 +290,11 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
 
 #define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env)
 
-
 #define JMPENV_PUSH_ENV(ce,v) \
     STMT_START {                                               \
        if (!(ce).je_noset) {                                   \
+           DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+                            ce, PL_top_env));                  \
            JMPENV_PUSH_INIT_ENV(ce,NULL);                      \
            EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf, 1));\
            (ce).je_noset = 1;                                  \
@@ -305,7 +308,10 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
 #define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) 
 
 #define JMPENV_POP_ENV(ce) \
-    STMT_START { PL_top_env = (ce).je_prev; } STMT_END
+    STMT_START {                                               \
+       if (PL_top_env == &(ce))                                \
+           PL_top_env = (ce).je_prev;                          \
+    } STMT_END
 
 #define JMPENV_POP  JMPENV_POP_ENV(*(JMPENV*)pcur_env) 
 
@@ -329,5 +335,38 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
 #define EXCEPT_SET_ENV(ce,v)   ((ce).je_ret = (v))
 #define EXCEPT_SET(v)          EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v)
 
+#else /* !PERL_FLEXIBLE_EXCEPTIONS */
+
+#define dJMPENV                JMPENV cur_env
+
+#define JMPENV_PUSH(v) \
+    STMT_START {                                                       \
+       DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n",     \
+                        &cur_env, PL_top_env));                        \
+       cur_env.je_prev = PL_top_env;                                   \
+       OP_REG_TO_MEM;                                                  \
+       cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1);            \
+       OP_MEM_TO_REG;                                                  \
+       PL_top_env = &cur_env;                                          \
+       cur_env.je_mustcatch = FALSE;                                   \
+       (v) = cur_env.je_ret;                                           \
+    } STMT_END
+
+#define JMPENV_POP \
+    STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
+#define JMPENV_JUMP(v) \
+    STMT_START {                                               \
+       OP_REG_TO_MEM;                                          \
+       if (PL_top_env->je_prev)                                \
+           PerlProc_longjmp(PL_top_env->je_buf, (v));          \
+       if ((v) == 2)                                           \
+           PerlProc_exit(STATUS_NATIVE_EXPORT);                \
+       PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
+       PerlProc_exit(1);                                       \
+    } STMT_END
+
+#endif /* PERL_FLEXIBLE_EXCEPTIONS */
+
 #define CATCH_GET              (PL_top_env->je_mustcatch)
 #define CATCH_SET(v)           (PL_top_env->je_mustcatch = (v))
diff --git a/sv.c b/sv.c
index 7b52000..43ed4e4 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -107,7 +107,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
     SV* sva = (SV*)ptr;
     register SV* sv;
     register SV* svend;
-    Zero(sva, size, char);
+    Zero(ptr, size, char);
 
     /* The first SV in an arena isn't an SV. */
     SvANY(sva) = (void *) PL_sv_arenaroot;             /* ptr to next arena */
@@ -7853,7 +7853,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_dirty           = proto_perl->Tdirty;
     PL_localizing      = proto_perl->Tlocalizing;
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
     PL_protect         = proto_perl->Tprotect;
+#endif
     PL_errors          = sv_dup_inc(proto_perl->Terrors);
     PL_av_fetch_sv     = Nullsv;
     PL_hv_fetch_sv     = Nullsv;
index 814842c..e4cfacc 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
  *
  * When building without USE_THREADS, these variables will be truly global.
  * When building without USE_THREADS but with MULTIPLICITY, these variables
- * will be global per-interpreter.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING.  That way,
- * we can keep binary compatibility of the curinterp structure */
+ * will be global per-interpreter. */
 
 /* Important ones in the first cache line (if alignment is done right) */
 
@@ -112,7 +109,9 @@ PERLVAR(Tmainstack, AV *)           /* the stack when nothing funny is happening */
 
 PERLVAR(Ttop_env,      JMPENV *)       /* ptr. to current sigjmp() environment */
 PERLVAR(Tstart_env,    JMPENV)         /* empty startup sigjmp() environment */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 PERLVARI(Tprotect,     protect_proc_t, MEMBER_TO_FPTR(Perl_default_protect))
+#endif
 PERLVARI(Terrors,      SV *, Nullsv)   /* outstanding queued errors */
 
 /* statics "owned" by various functions */
diff --git a/util.c b/util.c
index 6359125..1525d53 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3488,7 +3488,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     /* parent thread's data needs to be locked while we make copy */
     MUTEX_LOCK(&t->mutex);
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
     PL_protect = t->Tprotect;
+#endif
 
     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
     PL_defstash = t->Tdefstash;   /* XXX maybe these should */