X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=scope.c;h=1597acc9dc38d3c8daa7a7132d8f5b6c5aa34e51;hb=54e82ce5cfd72fcdc60806373e0c4d6890b68a3c;hp=58272e12a5044533a3284dd3fd57a83f8b982a29;hpb=864dbfa3ca8032ef66f7aa86961933b19b962357;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/scope.c b/scope.c
index 58272e1..1597acc 100644
--- a/scope.c
+++ b/scope.c
@@ -17,24 +17,32 @@
 #include "perl.h"
 
 void *
-Perl_default_protect(pTHX_ int *excpt, protect_body_t body, ...)
+Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
+		     protect_body_t body, ...)
 {
-    dTHR;
-    dJMPENV;
+    void *ret;
     va_list args;
+    va_start(args, body);
+    ret = vdefault_protect(pcur_env, excpt, body, &args);
+    va_end(args);
+    return ret;
+}
+
+void *
+Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
+		      protect_body_t body, va_list *args)
+{
+    dTHR;
     int ex;
     void *ret;
 
-    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n",
-		&cur_env, PL_top_env));
+    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;
-    else {
-	va_start(args, body);
-	ret = CALL_FPTR(body)(args);
-	va_end(args);
-    }
+    else
+	ret = CALL_FPTR(body)(aTHX_ *args);
     *excpt = ex;
     JMPENV_POP;
     return ret;
@@ -189,7 +197,7 @@ Perl_free_tmps(pTHX)
 }
 
 STATIC SV *
-save_scalar_at(pTHX_ SV **sptr)
+S_save_scalar_at(pTHX_ SV **sptr)
 {
     dTHR;
     register SV *sv;
@@ -430,12 +438,12 @@ Perl_save_threadsv(pTHX_ PADOFFSET i)
 #ifdef USE_THREADS
     dTHR;
     SV **svp = &THREADSV(i);	/* XXX Change to save by offset */
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n",
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %u: %p %p:%s\n",
 			  i, svp, *svp, SvPEEK(*svp)));
     save_svref(svp);
     return svp;
 #else
-    croak("panic: save_threadsv called in non-threaded perl");
+    Perl_croak(aTHX_ "panic: save_threadsv called in non-threaded perl");
     return 0;
 #endif /* USE_THREADS */
 }
@@ -534,11 +542,7 @@ Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
 }
 
 void
-#ifdef PERL_OBJECT
-Perl_save_destructor(pTHX_ DESTRUCTORFUNC f, void* p)
-#else
-Perl_save_destructor(pTHX_ void (*f) (void *), void *p)
-#endif
+Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 {
     dTHR;
     SSCHECK(3);
@@ -548,6 +552,16 @@ Perl_save_destructor(pTHX_ void (*f) (void *), void *p)
 }
 
 void
+Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
+{
+    dTHR;
+    SSCHECK(3);
+    SSPUSHDXPTR(f);
+    SSPUSHPTR(p);
+    SSPUSHINT(SAVEt_DESTRUCTOR_X);
+}
+
+void
 Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
 {
     dTHR;
@@ -611,7 +625,7 @@ Perl_leave_scope(pTHX_ I32 base)
     I32 i;
 
     if (base < -1)
-	croak("panic: corrupt saved stack index");
+	Perl_croak(aTHX_ "panic: corrupt saved stack index");
     while (PL_savestack_ix > base) {
 	switch (SSPOPINT) {
 	case SAVEt_ITEM:			/* normal string */
@@ -643,7 +657,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	restore_sv:
 	    sv = *(SV**)ptr;
-	    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+	    DEBUG_S(PerlIO_printf(Perl_debug_log,
 				  "restore svref: %p %p:%s -> %p:%s\n",
 			  	  ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
 	    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
@@ -795,7 +809,7 @@ Perl_leave_scope(pTHX_ I32 base)
 		    hv_clear((HV*)sv);
 		    break;
 		case SVt_PVCV:
-		    croak("panic: leave_scope pad code");
+		    Perl_croak(aTHX_ "panic: leave_scope pad code");
 		case SVt_RV:
 		case SVt_IV:
 		case SVt_NV:
@@ -828,7 +842,11 @@ Perl_leave_scope(pTHX_ I32 base)
 	    break;
 	case SAVEt_DESTRUCTOR:
 	    ptr = SSPOPPTR;
-	    CALLDESTRUCTOR(ptr);
+	    (*SSPOPDPTR)(ptr);
+	    break;
+	case SAVEt_DESTRUCTOR_X:
+	    ptr = SSPOPPTR;
+	    (*SSPOPDXPTR)(aTHXo_ ptr);
 	    break;
 	case SAVEt_REGCONTEXT:
 	case SAVEt_ALLOC:
@@ -887,7 +905,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    *(I32*)&PL_hints = (I32)SSPOPINT;
 	    break;
 	default:
-	    croak("panic: leave_scope inconsistency");
+	    Perl_croak(aTHX_ "panic: leave_scope inconsistency");
 	}
     }
 }