X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=scope.c;h=0f568543ba07fa0c157030f228cc0627c57c229f;hb=7fa2f4f15785dd46abca32ba3f3cb3aabf0263dd;hp=8952f43a5987a52aec82914dbca4d04f102b3f1a;hpb=bf49b057b09bec860588a9b554c3a77683394722;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/scope.c b/scope.c
index 8952f43..0f56854 100644
--- a/scope.c
+++ b/scope.c
@@ -1,6 +1,6 @@
 /*    scope.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -17,26 +17,27 @@
 #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, ...)
 {
     void *ret;
     va_list args;
     va_start(args, body);
-    ret = vdefault_protect(excpt, body, &args);
+    ret = vdefault_protect(pcur_env, excpt, body, &args);
     va_end(args);
     return ret;
 }
 
 void *
-Perl_vdefault_protect(pTHX_ int *excpt, protect_body_t body, va_list *args)
+Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
+		      protect_body_t body, va_list *args)
 {
     dTHR;
-    dJMPENV;
     int ex;
     void *ret;
 
     DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n",
-		&cur_env, PL_top_env));
+		pcur_env, PL_top_env));
     JMPENV_PUSH(ex);
     if (ex)
 	ret = NULL;
@@ -278,12 +279,17 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
     if (empty) {
 	register GP *gp;
 
+	Newz(602, gp, 1, GP);
+
 	if (GvCVu(gv))
 	    PL_sub_generation++;	/* taking a method out of circulation */
-	Newz(602, gp, 1, GP);
+	if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
+	    gp->gp_io = newIO();
+	    IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
+	}
 	GvGP(gv) = gp_ref(gp);
 	GvSV(gv) = NEWSV(72,0);
-	GvLINE(gv) = PL_curcop->cop_line;
+	GvLINE(gv) = CopLINE(PL_curcop);
 	GvEGV(gv) = gv;
     }
     else {
@@ -399,6 +405,16 @@ Perl_save_I16(pTHX_ I16 *intp)
 }
 
 void
+Perl_save_I8(pTHX_ I8 *bytep)
+{
+    dTHR;
+    SSCHECK(3);
+    SSPUSHINT(*bytep);
+    SSPUSHPTR(bytep);
+    SSPUSHINT(SAVEt_I8);
+}
+
+void
 Perl_save_iv(pTHX_ IV *ivp)
 {
     dTHR;
@@ -422,6 +438,16 @@ Perl_save_pptr(pTHX_ char **pptr)
 }
 
 void
+Perl_save_vptr(pTHX_ void *ptr)
+{
+    dTHR;
+    SSCHECK(3);
+    SSPUSHPTR(*(char**)ptr);
+    SSPUSHPTR(ptr);
+    SSPUSHINT(SAVEt_VPTR);
+}
+
+void
 Perl_save_sptr(pTHX_ SV **sptr)
 {
     dTHR;
@@ -437,8 +463,8 @@ Perl_save_threadsv(pTHX_ PADOFFSET i)
 #ifdef USE_THREADS
     dTHR;
     SV **svp = &THREADSV(i);	/* XXX Change to save by offset */
-    DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %u: %p %p:%s\n",
-			  i, svp, *svp, SvPEEK(*svp)));
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
+			  (UV)i, svp, *svp, SvPEEK(*svp)));
     save_svref(svp);
     return svp;
 #else
@@ -541,7 +567,7 @@ Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
 }
 
 void
-Perl_save_destructor(pTHX_ DESTRUCTORFUNC_t f, void* p)
+Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 {
     dTHR;
     SSCHECK(3);
@@ -551,6 +577,16 @@ Perl_save_destructor(pTHX_ DESTRUCTORFUNC_t f, 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;
@@ -725,6 +761,10 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    *(I16*)ptr = (I16)SSPOPINT;
 	    break;
+	case SAVEt_I8:				/* I8 reference */
+	    ptr = SSPOPPTR;
+	    *(I8*)ptr = (I8)SSPOPINT;
+	    break;
 	case SAVEt_IV:				/* IV reference */
 	    ptr = SSPOPPTR;
 	    *(IV*)ptr = (IV)SSPOPIV;
@@ -733,6 +773,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    *(SV**)ptr = (SV*)SSPOPPTR;
 	    break;
+	case SAVEt_VPTR:			/* random* reference */
 	case SAVEt_PPTR:			/* char* reference */
 	    ptr = SSPOPPTR;
 	    *(char**)ptr = (char*)SSPOPPTR;
@@ -831,7 +872,11 @@ Perl_leave_scope(pTHX_ I32 base)
 	    break;
 	case SAVEt_DESTRUCTOR:
 	    ptr = SSPOPPTR;
-	    CALLDESTRUCTOR(aTHXo_ ptr);
+	    (*SSPOPDPTR)(ptr);
+	    break;
+	case SAVEt_DESTRUCTOR_X:
+	    ptr = SSPOPPTR;
+	    (*SSPOPDXPTR)(aTHXo_ ptr);
 	    break;
 	case SAVEt_REGCONTEXT:
 	case SAVEt_ALLOC:
@@ -889,6 +934,13 @@ Perl_leave_scope(pTHX_ I32 base)
 	    }
 	    *(I32*)&PL_hints = (I32)SSPOPINT;
 	    break;
+	case SAVEt_COMPPAD:
+	    PL_comppad = (AV*)SSPOPPTR;
+	    if (PL_comppad)
+		PL_curpad = AvARRAY(PL_comppad);
+	    else
+		PL_curpad = Null(SV**);
+	    break;
 	default:
 	    Perl_croak(aTHX_ "panic: leave_scope inconsistency");
 	}
@@ -903,28 +955,38 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
     if (CxTYPE(cx) != CXt_SUBST) {
 	PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
-	PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
+	PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
+		      PTR2UV(cx->blk_oldcop));
 	PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
-	PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
+	PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
+		      PTR2UV(cx->blk_oldpm));
 	PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
     }
     switch (CxTYPE(cx)) {
     case CXt_NULL:
     case CXt_BLOCK:
 	break;
+    case CXt_FORMAT:
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_sub.cv));
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_sub.gv));
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_sub.dfoutgv));
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
+		(int)cx->blk_sub.hasargs);
+	break;
     case CXt_SUB:
-	PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
-		(long)cx->blk_sub.cv);
-	PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
-		(long)cx->blk_sub.gv);
-	PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
-		(long)cx->blk_sub.dfoutgv);
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_sub.cv));
 	PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
 		(long)cx->blk_sub.olddepth);
 	PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
 		(int)cx->blk_sub.hasargs);
+	PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n",
+		(int)cx->blk_sub.lval);
 	break;
     case CXt_EVAL:
 	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
@@ -934,8 +996,8 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		PL_op_desc[cx->blk_eval.old_op_type]);
 	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
 		cx->blk_eval.old_name);
-	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
-		(long)cx->blk_eval.old_eval_root);
+	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_eval.old_eval_root));
 	break;
 
     case CXt_LOOP:
@@ -943,23 +1005,23 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		cx->blk_loop.label);
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
 		(long)cx->blk_loop.resetsp);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n",
-		(long)cx->blk_loop.redo_op);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n",
-		(long)cx->blk_loop.next_op);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n",
-		(long)cx->blk_loop.last_op);
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.redo_op));
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.next_op));
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.last_op));
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
 		(long)cx->blk_loop.iterix);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
-		(long)cx->blk_loop.iterary);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n",
-		(long)cx->blk_loop.itervar);
-	if (cx->blk_loop.itervar)
-	    PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
-		(long)cx->blk_loop.itersave);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
-		(long)cx->blk_loop.iterlval);
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.iterary));
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
+		PTR2UV(CxITERVAR(cx)));
+	if (CxITERVAR(cx))
+	    PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.itersave));
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.iterlval));
 	break;
 
     case CXt_SUBST:
@@ -973,18 +1035,18 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		(long)cx->sb_once);
 	PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
 		cx->sb_orig);
-	PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
-		(long)cx->sb_dstr);
-	PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
-		(long)cx->sb_targ);
-	PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
-		(long)cx->sb_s);
-	PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
-		(long)cx->sb_m);
-	PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
-		(long)cx->sb_strend);
-	PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n",
-		(long)cx->sb_rxres);
+	PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_dstr));
+	PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_targ));
+	PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_s));
+	PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_m));
+	PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_strend));
+	PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
+		PTR2UV(cx->sb_rxres));
 	break;
     }
 #endif	/* DEBUGGING */