Remove unneeded pragma line from B/t/OptreeCheck.pm
[perl.git] / cop.h
1 /*    cop.h
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
10  * and OP_SETSTATE that (loosely speaking) are separate statements.
11  * They hold information important for lexical state and error reporting.
12  * At run time, PL_curcop is set to point to the most recently executed cop,
13  * and thus can be used to determine our current state.
14  */
15
16 /* A jmpenv packages the state required to perform a proper non-local jump.
17  * Note that there is a start_env initialized when perl starts, and top_env
18  * points to this initially, so top_env should always be non-null.
19  *
20  * Existence of a non-null top_env->je_prev implies it is valid to call
21  * longjmp() at that runlevel (we make sure start_env.je_prev is always
22  * null to ensure this).
23  *
24  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
25  * establish a local jmpenv to handle exception traps.  Care must be taken
26  * to restore the previous value of je_mustcatch before exiting the
27  * stack frame iff JMPENV_PUSH was not called in that stack frame.
28  * GSAR 97-03-27
29  */
30
31 struct jmpenv {
32     struct jmpenv *     je_prev;
33     Sigjmp_buf          je_buf;         /* only for use if !je_throw */
34     int                 je_ret;         /* last exception thrown */
35     bool                je_mustcatch;   /* need to call longjmp()? */
36 };
37
38 typedef struct jmpenv JMPENV;
39
40 #ifdef OP_IN_REGISTER
41 #define OP_REG_TO_MEM   PL_opsave = op
42 #define OP_MEM_TO_REG   op = PL_opsave
43 #else
44 #define OP_REG_TO_MEM   NOOP
45 #define OP_MEM_TO_REG   NOOP
46 #endif
47
48 /*
49  * How to build the first jmpenv.
50  *
51  * top_env needs to be non-zero. It points to an area
52  * in which longjmp() stuff is stored, as C callstack
53  * info there at least is thread specific this has to
54  * be per-thread. Otherwise a 'die' in a thread gives
55  * that thread the C stack of last thread to do an eval {}!
56  */
57
58 #define JMPENV_BOOTSTRAP \
59     STMT_START {                                \
60         Zero(&PL_start_env, 1, JMPENV);         \
61         PL_start_env.je_ret = -1;               \
62         PL_start_env.je_mustcatch = TRUE;       \
63         PL_top_env = &PL_start_env;             \
64     } STMT_END
65
66 /*
67  *   PERL_FLEXIBLE_EXCEPTIONS
68  * 
69  * All the flexible exceptions code has been removed.
70  * See the following threads for details:
71  *
72  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
73  * 
74  * Joshua's original patches (which weren't applied) and discussion:
75  * 
76  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
77  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
78  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
79  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
80  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
81  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
82  * 
83  * Chip's reworked patch and discussion:
84  * 
85  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
86  * 
87  * The flaw in these patches (which went unnoticed at the time) was
88  * that they moved some code that could potentially die() out of the
89  * region protected by the setjmp()s.  This caused exceptions within
90  * END blocks and such to not be handled by the correct setjmp().
91  * 
92  * The original patches that introduces flexible exceptions were:
93  *
94  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=3386
95  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=5162
96  */
97
98 #define dJMPENV         JMPENV cur_env
99
100 #define JMPENV_PUSH(v) \
101     STMT_START {                                                        \
102         DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n",     \
103                          (void*)&cur_env, (void*)PL_top_env));                  \
104         cur_env.je_prev = PL_top_env;                                   \
105         OP_REG_TO_MEM;                                                  \
106         cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK);              \
107         OP_MEM_TO_REG;                                                  \
108         PL_top_env = &cur_env;                                          \
109         cur_env.je_mustcatch = FALSE;                                   \
110         (v) = cur_env.je_ret;                                           \
111     } STMT_END
112
113 #define JMPENV_POP \
114     STMT_START {                                                        \
115         DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n",    \
116                          (void*)PL_top_env, (void*)cur_env.je_prev));                   \
117         PL_top_env = cur_env.je_prev;                                   \
118     } STMT_END
119
120 #define JMPENV_JUMP(v) \
121     STMT_START {                                                \
122         OP_REG_TO_MEM;                                          \
123         if (PL_top_env->je_prev)                                \
124             PerlProc_longjmp(PL_top_env->je_buf, (v));          \
125         if ((v) == 2)                                           \
126             PerlProc_exit(STATUS_EXIT);                         \
127         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
128         PerlProc_exit(1);                                       \
129     } STMT_END
130
131 #define CATCH_GET               (PL_top_env->je_mustcatch)
132 #define CATCH_SET(v)            (PL_top_env->je_mustcatch = (v))
133
134
135
136 struct cop {
137     BASEOP
138     char *      cop_label;      /* label for this construct */
139 #ifdef USE_ITHREADS
140     char *      cop_stashpv;    /* package line was compiled in */
141     char *      cop_file;       /* file name the following line # is from */
142 #else
143     HV *        cop_stash;      /* package line was compiled in */
144     GV *        cop_filegv;     /* file the following line # is from */
145 #endif
146     U32         cop_hints;      /* hints bits from pragmata */
147     U32         cop_seq;        /* parse sequence number */
148     line_t      cop_line;       /* line # of this command */
149     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
150     STRLEN *    cop_warnings;   /* lexical warnings bitmask */
151     /* compile time state of %^H.  See the comment in op.c for how this is
152        used to recreate a hash to return from caller.  */
153     struct refcounted_he * cop_hints_hash;
154 };
155
156 #ifdef USE_ITHREADS
157 #  define CopFILE(c)            ((c)->cop_file)
158 #  define CopFILEGV(c)          (CopFILE(c) \
159                                  ? gv_fetchfile(CopFILE(c)) : NULL)
160                                  
161 #  ifdef NETWARE
162 #    define CopFILE_set(c,pv)   ((c)->cop_file = savepv(pv))
163 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savepv((pv),(l)))
164 #  else
165 #    define CopFILE_set(c,pv)   ((c)->cop_file = savesharedpv(pv))
166 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savesharedpvn((pv),(l)))
167 #  endif
168
169 #  define CopFILESV(c)          (CopFILE(c) \
170                                  ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
171 #  define CopFILEAV(c)          (CopFILE(c) \
172                                  ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
173 #  ifdef DEBUGGING
174 #    define CopFILEAVx(c)       (assert(CopFILE(c)), \
175                                    GvAV(gv_fetchfile(CopFILE(c))))
176 #  else
177 #    define CopFILEAVx(c)       (GvAV(gv_fetchfile(CopFILE(c))))
178 #  endif
179 #  define CopSTASHPV(c)         ((c)->cop_stashpv)
180
181 #  ifdef NETWARE
182 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
183 #  else
184 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = savesharedpv(pv))
185 #  endif
186
187 #  define CopSTASH(c)           (CopSTASHPV(c) \
188                                  ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
189 #  define CopSTASH_set(c,hv)    CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
190 #  define CopSTASH_eq(c,hv)     ((hv) && stashpv_hvname_match(c,hv))
191 #  define CopLABEL(c)           ((c)->cop_label)
192 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
193 #  ifdef NETWARE
194 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
195 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
196 #    define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
197 #    define CopLABEL_alloc(pv)  ((pv)?savepv(pv):NULL)
198 #  else
199 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
200 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
201 #    define CopLABEL_free(c)    (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
202 #    define CopLABEL_alloc(pv)  ((pv)?savesharedpv(pv):NULL)
203 #  endif
204 #else
205 #  define CopFILEGV(c)          ((c)->cop_filegv)
206 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
207 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
208 #  define CopFILE_setn(c,pv,l)  CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
209 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
210 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
211 #  ifdef DEBUGGING
212 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
213 #  else
214 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
215 # endif
216 #  define CopFILE(c)            (CopFILESV(c) ? SvPVX(CopFILESV(c)) : NULL)
217 #  define CopSTASH(c)           ((c)->cop_stash)
218 #  define CopLABEL(c)           ((c)->cop_label)
219 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
220 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
221    /* cop_stash is not refcounted */
222 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
223 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
224 #  define CopLABEL_alloc(pv)    ((pv)?savepv(pv):NULL)
225 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
226 #  define CopSTASH_free(c)      
227 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
228 #  define CopLABEL_free(c)      (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
229
230 #endif /* USE_ITHREADS */
231
232 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
233 #define CopLINE(c)              ((c)->cop_line)
234 #define CopLINE_inc(c)          (++CopLINE(c))
235 #define CopLINE_dec(c)          (--CopLINE(c))
236 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
237
238 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
239 #ifdef MACOS_TRADITIONAL
240 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
241 #else
242 #  define OutCopFILE(c) CopFILE(c)
243 #endif
244
245 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
246    HINT_ARYBASE is set to indicate this.
247    Setting it is ineficient due to the need to create 2 mortal SVs, but as
248    using $[ is highly discouraged, no sane Perl code will be using it.  */
249 #define CopARYBASE_get(c)       \
250         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
251          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
252                                          "$[", 2, 0, 0))                \
253          : 0)
254 #define CopARYBASE_set(c, b) STMT_START { \
255         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
256             (c)->cop_hints |= HINT_ARYBASE;                             \
257             if ((c) == &PL_compiling)                                   \
258                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
259             (c)->cop_hints_hash                                         \
260                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
261                                         sv_2mortal(newSVpvs("$[")),     \
262                                         sv_2mortal(newSViv(b)));        \
263         }                                                               \
264     } STMT_END
265
266 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
267 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
268 #define CopHINTS_set(c, h)      STMT_START {                            \
269                                     (c)->cop_hints = (h);               \
270                                 } STMT_END
271
272 /*
273  * Here we have some enormously heavy (or at least ponderous) wizardry.
274  */
275
276 /* subroutine context */
277 struct block_sub {
278     CV *        cv;
279     GV *        gv;
280     GV *        dfoutgv;
281     AV *        savearray;
282     AV *        argarray;
283     I32         olddepth;
284     U8          hasargs;
285     U8          lval;           /* XXX merge lval and hasargs? */
286     PAD         *oldcomppad;
287     OP *        retop;  /* op to execute on exit from sub */
288 };
289
290 /* base for the next two macros. Don't use directly.
291  * Note that the refcnt of the cv is incremented twice;  The CX one is
292  * decremented by LEAVESUB, the other by LEAVE. */
293
294 #define PUSHSUB_BASE(cx)                                                \
295         cx->blk_sub.cv = cv;                                            \
296         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
297         cx->blk_sub.hasargs = hasargs;                                  \
298         cx->blk_sub.retop = NULL;                                       \
299         if (!CvDEPTH(cv)) {                                             \
300             SvREFCNT_inc_simple_void_NN(cv);                            \
301             SvREFCNT_inc_simple_void_NN(cv);                            \
302             SAVEFREESV(cv);                                             \
303         }
304
305
306 #define PUSHSUB(cx)                                                     \
307         PUSHSUB_BASE(cx)                                                \
308         cx->blk_sub.lval = PL_op->op_private &                          \
309                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
310
311 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
312 #define PUSHSUB_DB(cx)                                                  \
313         PUSHSUB_BASE(cx)                                                \
314         cx->blk_sub.lval = 0;
315
316
317 #define PUSHFORMAT(cx)                                                  \
318         cx->blk_sub.cv = cv;                                            \
319         cx->blk_sub.gv = gv;                                            \
320         cx->blk_sub.retop = NULL;                                       \
321         cx->blk_sub.hasargs = 0;                                        \
322         cx->blk_sub.dfoutgv = PL_defoutgv;                              \
323         SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
324
325 #define POP_SAVEARRAY()                                         \
326     STMT_START {                                                        \
327         SvREFCNT_dec(GvAV(PL_defgv));                                   \
328         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
329     } STMT_END
330
331 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
332  * leave any (a fast av_clear(ary), basically) */
333 #define CLEAR_ARGARRAY(ary) \
334     STMT_START {                                                        \
335         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
336         AvARRAY(ary) = AvALLOC(ary);                                    \
337         AvFILLp(ary) = -1;                                              \
338     } STMT_END
339
340 #define POPSUB(cx,sv)                                                   \
341     STMT_START {                                                        \
342         if (cx->blk_sub.hasargs) {                                      \
343             POP_SAVEARRAY();                                            \
344             /* abandon @_ if it got reified */                          \
345             if (AvREAL(cx->blk_sub.argarray)) {                         \
346                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
347                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
348                 cx->blk_sub.argarray = newAV();                         \
349                 av_extend(cx->blk_sub.argarray, fill);                  \
350                 AvREIFY_only(cx->blk_sub.argarray);                     \
351                 CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray;       \
352             }                                                           \
353             else {                                                      \
354                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
355             }                                                           \
356         }                                                               \
357         sv = (SV*)cx->blk_sub.cv;                                       \
358         if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))            \
359             sv = NULL;                                          \
360     } STMT_END
361
362 #define LEAVESUB(sv)                                                    \
363     STMT_START {                                                        \
364         if (sv)                                                         \
365             SvREFCNT_dec(sv);                                           \
366     } STMT_END
367
368 #define POPFORMAT(cx)                                                   \
369         setdefout(cx->blk_sub.dfoutgv);                                 \
370         SvREFCNT_dec(cx->blk_sub.dfoutgv);
371
372 /* eval context */
373 struct block_eval {
374     U8          old_in_eval;
375     U16         old_op_type;
376     SV *        old_namesv;
377     OP *        old_eval_root;
378     SV *        cur_text;
379     CV *        cv;
380     OP *        retop;  /* op to execute on exit from eval */
381     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
382 };
383
384 #define PUSHEVAL(cx,n,fgv)                                              \
385     STMT_START {                                                        \
386         cx->blk_eval.old_in_eval = PL_in_eval;                          \
387         cx->blk_eval.old_op_type = PL_op->op_type;                      \
388         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
389         cx->blk_eval.old_eval_root = PL_eval_root;                      \
390         cx->blk_eval.cur_text = PL_linestr;                             \
391         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
392         cx->blk_eval.retop = NULL;                                      \
393         cx->blk_eval.cur_top_env = PL_top_env;                          \
394     } STMT_END
395
396 #define POPEVAL(cx)                                                     \
397     STMT_START {                                                        \
398         PL_in_eval = cx->blk_eval.old_in_eval;                          \
399         optype = cx->blk_eval.old_op_type;                              \
400         PL_eval_root = cx->blk_eval.old_eval_root;                      \
401         if (cx->blk_eval.old_namesv)                                    \
402             sv_2mortal(cx->blk_eval.old_namesv);                        \
403     } STMT_END
404
405 /* loop context */
406 struct block_loop {
407     char *      label;
408     I32         resetsp;
409     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
410     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
411         why next_op is conditionally defined below.)  */
412 #ifdef USE_ITHREADS
413     void *      iterdata;
414     PAD         *oldcomppad;
415 #else
416     OP *        next_op;
417     SV **       itervar;
418 #endif
419     SV *        itersave;
420     /* (from inspection of source code) for a .. range of strings this is the
421        current string.  */
422     SV *        iterlval;
423     /* (from inspection of source code) for a foreach loop this is the array
424        being iterated over. For a .. range of numbers it's the current value.
425        A check is often made on the SvTYPE of iterary to determine whether
426        we are iterating over an array or a range. (numbers or strings)  */
427     AV *        iterary;
428     IV          iterix;
429     /* (from inspection of source code) for a .. range of numbers this is the
430        maximum value.  */
431     IV          itermax;
432 };
433 /* It might be possible to squeeze this structure further. As best I can tell
434    itermax and iterlval are never used at the same time, so it might be possible
435    to make them into a union. However, I'm not confident that there are enough
436    flag bits/NULLable pointers in this structure alone to encode which is
437    active. There is, however, U8 of space free in struct block, which could be
438    used. Right now it may not be worth squeezing this structure further, as it's
439    the largest part of struct block, and currently struct block is 64 bytes on
440    an ILP32 system, which will give good cache alignment.
441 */
442
443 #ifdef USE_ITHREADS
444 #  define CxITERVAR(c)                                                  \
445         ((c)->blk_loop.iterdata                                         \
446          ? (CxPADLOOP(cx)                                               \
447             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
448                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
449             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
450          : (SV**)NULL)
451 #  define CX_ITERDATA_SET(cx,idata)                                     \
452         CX_CURPAD_SAVE(cx->blk_loop);                                   \
453         if ((cx->blk_loop.iterdata = (idata)))                          \
454             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
455         else                                                            \
456             cx->blk_loop.itersave = NULL;
457 #else
458 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
459 #  define CX_ITERDATA_SET(cx,ivar)                                      \
460         if ((cx->blk_loop.itervar = (SV**)(ivar)))                      \
461             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
462         else                                                            \
463             cx->blk_loop.itersave = NULL;
464 #endif
465
466 #ifdef USE_ITHREADS
467 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
468 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
469 #else
470 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
471 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
472 #endif
473
474 #define PUSHLOOP(cx, dat, s)                                            \
475         cx->blk_loop.label = PL_curcop->cop_label;                      \
476         cx->blk_loop.resetsp = s - PL_stack_base;                       \
477         cx->blk_loop.my_op = cLOOP;                                     \
478         PUSHLOOP_OP_NEXT;                                               \
479         cx->blk_loop.iterlval = NULL;                                   \
480         cx->blk_loop.iterary = NULL;                                    \
481         cx->blk_loop.iterix = -1;                                       \
482         CX_ITERDATA_SET(cx,dat);
483
484 #define POPLOOP(cx)                                                     \
485         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
486         if (CxITERVAR(cx)) {                                            \
487             if (SvPADMY(cx->blk_loop.itersave)) {                       \
488                 SV ** const s_v_p = CxITERVAR(cx);                      \
489                 sv_2mortal(*s_v_p);                                     \
490                 *s_v_p = cx->blk_loop.itersave;                         \
491             }                                                           \
492             else {                                                      \
493                 SvREFCNT_dec(cx->blk_loop.itersave);                    \
494             }                                                           \
495         }                                                               \
496         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
497             SvREFCNT_dec(cx->blk_loop.iterary);
498
499 /* given/when context */
500 struct block_givwhen {
501         OP *leave_op;
502 };
503
504 #define PUSHGIVEN(cx)                                                   \
505         cx->blk_givwhen.leave_op = cLOGOP->op_other;
506
507 #define PUSHWHEN PUSHGIVEN
508
509 /* context common to subroutines, evals and loops */
510 struct block {
511     U16         blku_type;      /* what kind of context this is */
512     U8          blku_gimme;     /* is this block running in list context? */
513     U8          blku_spare;     /* Padding to match with struct subst */
514     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
515     COP *       blku_oldcop;    /* old curcop pointer */
516     I32         blku_oldmarksp; /* mark stack index */
517     I32         blku_oldscopesp;        /* scope stack index */
518     PMOP *      blku_oldpm;     /* values of pattern match vars */
519
520     union {
521         struct block_sub        blku_sub;
522         struct block_eval       blku_eval;
523         struct block_loop       blku_loop;
524         struct block_givwhen    blku_givwhen;
525     } blk_u;
526 };
527 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
528 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
529 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
530 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
531 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
532 #define blk_gimme       cx_u.cx_blk.blku_gimme
533 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
534 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
535 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
536 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
537
538 /* Enter a block. */
539 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
540         cx->cx_type             = t,                                    \
541         cx->blk_oldsp           = sp - PL_stack_base,                   \
542         cx->blk_oldcop          = PL_curcop,                            \
543         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
544         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
545         cx->blk_oldpm           = PL_curpm,                             \
546         cx->blk_gimme           = (U8)gimme;                            \
547         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
548                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
549
550 /* Exit a block (RETURN and LAST). */
551 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
552         newsp            = PL_stack_base + cx->blk_oldsp,               \
553         PL_curcop        = cx->blk_oldcop,                              \
554         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
555         PL_scopestack_ix = cx->blk_oldscopesp,                          \
556         pm               = cx->blk_oldpm,                               \
557         gimme            = cx->blk_gimme;                               \
558         DEBUG_SCOPE("POPBLOCK");                                        \
559         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
560                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
561
562 /* Continue a block elsewhere (NEXT and REDO). */
563 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
564         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
565         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
566         PL_scopestack_ix = cx->blk_oldscopesp,                          \
567         PL_curpm         = cx->blk_oldpm;                               \
568         DEBUG_SCOPE("TOPBLOCK");
569
570 /* substitution context */
571 struct subst {
572     U16         sbu_type;       /* what kind of context this is */
573     U8          sbu_once;       /* Actually both booleans, but U8 to matches */
574     U8          sbu_rxtainted;  /* struct block */
575     I32         sbu_iters;
576     I32         sbu_maxiters;
577     I32         sbu_rflags;
578     I32         sbu_oldsave;
579     char *      sbu_orig;
580     SV *        sbu_dstr;
581     SV *        sbu_targ;
582     char *      sbu_s;
583     char *      sbu_m;
584     char *      sbu_strend;
585     void *      sbu_rxres;
586     REGEXP *    sbu_rx;
587 };
588 #define sb_iters        cx_u.cx_subst.sbu_iters
589 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
590 #define sb_rflags       cx_u.cx_subst.sbu_rflags
591 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
592 #define sb_once         cx_u.cx_subst.sbu_once
593 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
594 #define sb_orig         cx_u.cx_subst.sbu_orig
595 #define sb_dstr         cx_u.cx_subst.sbu_dstr
596 #define sb_targ         cx_u.cx_subst.sbu_targ
597 #define sb_s            cx_u.cx_subst.sbu_s
598 #define sb_m            cx_u.cx_subst.sbu_m
599 #define sb_strend       cx_u.cx_subst.sbu_strend
600 #define sb_rxres        cx_u.cx_subst.sbu_rxres
601 #define sb_rx           cx_u.cx_subst.sbu_rx
602
603 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
604         cx->sb_iters            = iters,                                \
605         cx->sb_maxiters         = maxiters,                             \
606         cx->sb_rflags           = r_flags,                              \
607         cx->sb_oldsave          = oldsave,                              \
608         cx->sb_once             = once,                                 \
609         cx->sb_rxtainted        = rxtainted,                            \
610         cx->sb_orig             = orig,                                 \
611         cx->sb_dstr             = dstr,                                 \
612         cx->sb_targ             = targ,                                 \
613         cx->sb_s                = s,                                    \
614         cx->sb_m                = m,                                    \
615         cx->sb_strend           = strend,                               \
616         cx->sb_rxres            = NULL,                                 \
617         cx->sb_rx               = rx,                                   \
618         cx->cx_type             = CXt_SUBST;                            \
619         rxres_save(&cx->sb_rxres, rx);                                  \
620         (void)ReREFCNT_inc(rx)
621
622 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
623         rxres_free(&cx->sb_rxres);                                      \
624         ReREFCNT_dec(cx->sb_rx)
625
626 struct context {
627     union {
628         struct block    cx_blk;
629         struct subst    cx_subst;
630     } cx_u;
631 };
632 #define cx_type cx_u.cx_subst.sbu_type
633
634 #define CXTYPEMASK      0xff
635 #define CXt_NULL        0
636 #define CXt_SUB         1
637 #define CXt_EVAL        2
638 #define CXt_LOOP        3
639 #define CXt_SUBST       4
640 #define CXt_BLOCK       5
641 #define CXt_FORMAT      6
642 #define CXt_GIVEN       7
643 #define CXt_WHEN        8
644
645 /* private flags for CXt_SUB and CXt_NULL */
646 #define CXp_MULTICALL   0x00000400      /* part of a multicall (so don't
647                                            tear down context on exit). */ 
648
649 /* private flags for CXt_EVAL */
650 #define CXp_REAL        0x00000100      /* truly eval'', not a lookalike */
651 #define CXp_TRYBLOCK    0x00000200      /* eval{}, not eval'' or similar */
652
653 /* private flags for CXt_LOOP */
654 #define CXp_FOREACH     0x00000200      /* a foreach loop */
655 #define CXp_FOR_DEF     0x00000400      /* foreach using $_ */
656 #ifdef USE_ITHREADS
657 #  define CXp_PADVAR    0x00000100      /* itervar lives on pad, iterdata
658                                            has pad offset; if not set,
659                                            iterdata holds GV* */
660 #  define CxPADLOOP(c)  (((c)->cx_type & (CXt_LOOP|CXp_PADVAR))         \
661                          == (CXt_LOOP|CXp_PADVAR))
662 #endif
663
664 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
665 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
666                          == CXp_MULTICALL)
667 #define CxREALEVAL(c)   (((c)->cx_type & (CXt_EVAL|CXp_REAL))           \
668                          == (CXt_EVAL|CXp_REAL))
669 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))       \
670                          == (CXt_EVAL|CXp_TRYBLOCK))
671 #define CxFOREACH(c)    (((c)->cx_type & (CXt_LOOP|CXp_FOREACH))        \
672                          == (CXt_LOOP|CXp_FOREACH))
673 #define CxFOREACHDEF(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))\
674                          == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
675
676 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
677
678 /* 
679 =head1 "Gimme" Values
680 */
681
682 /*
683 =for apidoc AmU||G_SCALAR
684 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
685 L<perlcall>.
686
687 =for apidoc AmU||G_ARRAY
688 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
689 L<perlcall>.
690
691 =for apidoc AmU||G_VOID
692 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
693
694 =for apidoc AmU||G_DISCARD
695 Indicates that arguments returned from a callback should be discarded.  See
696 L<perlcall>.
697
698 =for apidoc AmU||G_EVAL
699
700 Used to force a Perl C<eval> wrapper around a callback.  See
701 L<perlcall>.
702
703 =for apidoc AmU||G_NOARGS
704
705 Indicates that no arguments are being sent to a callback.  See
706 L<perlcall>.
707
708 =cut
709 */
710
711 #define G_SCALAR        0
712 #define G_ARRAY         1
713 #define G_VOID          128     /* skip this bit when adding flags below */
714
715 /* extra flags for Perl_call_* routines */
716 #define G_DISCARD       2       /* Call FREETMPS. */
717 #define G_EVAL          4       /* Assume eval {} around subroutine call. */
718 #define G_NOARGS        8       /* Don't construct a @_ array. */
719 #define G_KEEPERR      16       /* Append errors to $@, don't overwrite it */
720 #define G_NODEBUG      32       /* Disable debugging at toplevel.  */
721 #define G_METHOD       64       /* Calling method. */
722 #define G_FAKINGEVAL  256       /* Faking an eval context for call_sv or
723                                    fold_constants. */
724
725 /* flag bits for PL_in_eval */
726 #define EVAL_NULL       0       /* not in an eval */
727 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
728 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
729 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
730 #define EVAL_INREQUIRE  8       /* The code is being required. */
731
732 /* Support for switching (stack and block) contexts.
733  * This ensures magic doesn't invalidate local stack and cx pointers.
734  */
735
736 #define PERLSI_UNKNOWN          -1
737 #define PERLSI_UNDEF            0
738 #define PERLSI_MAIN             1
739 #define PERLSI_MAGIC            2
740 #define PERLSI_SORT             3
741 #define PERLSI_SIGNAL           4
742 #define PERLSI_OVERLOAD         5
743 #define PERLSI_DESTROY          6
744 #define PERLSI_WARNHOOK         7
745 #define PERLSI_DIEHOOK          8
746 #define PERLSI_REQUIRE          9
747
748 struct stackinfo {
749     AV *                si_stack;       /* stack for current runlevel */
750     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
751     I32                 si_cxix;        /* current context index */
752     I32                 si_cxmax;       /* maximum allocated index */
753     I32                 si_type;        /* type of runlevel */
754     struct stackinfo *  si_prev;
755     struct stackinfo *  si_next;
756     I32                 si_markoff;     /* offset where markstack begins for us.
757                                          * currently used only with DEBUGGING,
758                                          * but not #ifdef-ed for bincompat */
759 };
760
761 typedef struct stackinfo PERL_SI;
762
763 #define cxstack         (PL_curstackinfo->si_cxstack)
764 #define cxstack_ix      (PL_curstackinfo->si_cxix)
765 #define cxstack_max     (PL_curstackinfo->si_cxmax)
766
767 #ifdef DEBUGGING
768 #  define       SET_MARK_OFFSET \
769     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
770 #else
771 #  define       SET_MARK_OFFSET NOOP
772 #endif
773
774 #define PUSHSTACKi(type) \
775     STMT_START {                                                        \
776         PERL_SI *next = PL_curstackinfo->si_next;                       \
777         if (!next) {                                                    \
778             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
779             next->si_prev = PL_curstackinfo;                            \
780             PL_curstackinfo->si_next = next;                            \
781         }                                                               \
782         next->si_type = type;                                           \
783         next->si_cxix = -1;                                             \
784         AvFILLp(next->si_stack) = 0;                                    \
785         SWITCHSTACK(PL_curstack,next->si_stack);                        \
786         PL_curstackinfo = next;                                         \
787         SET_MARK_OFFSET;                                                \
788     } STMT_END
789
790 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
791
792 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
793  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
794 #define POPSTACK \
795     STMT_START {                                                        \
796         dSP;                                                            \
797         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
798         if (!prev) {                                                    \
799             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
800             my_exit(1);                                                 \
801         }                                                               \
802         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
803         /* don't free prev here, free them all at the END{} */          \
804         PL_curstackinfo = prev;                                         \
805     } STMT_END
806
807 #define POPSTACK_TO(s) \
808     STMT_START {                                                        \
809         while (PL_curstack != s) {                                      \
810             dounwind(-1);                                               \
811             POPSTACK;                                                   \
812         }                                                               \
813     } STMT_END
814
815 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
816 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
817
818 /*
819 =head1 Multicall Functions
820
821 =for apidoc Ams||dMULTICALL
822 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
823
824 =for apidoc Ams||PUSH_MULTICALL
825 Opening bracket for a lightweight callback.
826 See L<perlcall/Lightweight Callbacks>.
827
828 =for apidoc Ams||MULTICALL
829 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
830
831 =for apidoc Ams||POP_MULTICALL
832 Closing bracket for a lightweight callback.
833 See L<perlcall/Lightweight Callbacks>.
834
835 =cut
836 */
837
838 #define dMULTICALL \
839     SV **newsp;                 /* set by POPBLOCK */                   \
840     PERL_CONTEXT *cx;                                                   \
841     CV *multicall_cv;                                                   \
842     OP *multicall_cop;                                                  \
843     bool multicall_oldcatch;                                            \
844     U8 hasargs = 0              /* used by PUSHSUB */
845
846 #define PUSH_MULTICALL(the_cv) \
847     STMT_START {                                                        \
848         CV * const _nOnclAshIngNamE_ = the_cv;                          \
849         CV * const cv = _nOnclAshIngNamE_;                              \
850         AV * const padlist = CvPADLIST(cv);                             \
851         ENTER;                                                          \
852         multicall_oldcatch = CATCH_GET;                                 \
853         SAVETMPS; SAVEVPTR(PL_op);                                      \
854         CATCH_SET(TRUE);                                                \
855         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
856         PUSHSUB(cx);                                                    \
857         if (++CvDEPTH(cv) >= 2) {                                       \
858             PERL_STACK_OVERFLOW_CHECK();                                \
859             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
860         }                                                               \
861         SAVECOMPPAD();                                                  \
862         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
863         multicall_cv = cv;                                              \
864         multicall_cop = CvSTART(cv);                                    \
865     } STMT_END
866
867 #define MULTICALL \
868     STMT_START {                                                        \
869         PL_op = multicall_cop;                                          \
870         CALLRUNOPS(aTHX);                                               \
871     } STMT_END
872
873 #define POP_MULTICALL \
874     STMT_START {                                                        \
875         LEAVESUB(multicall_cv);                                         \
876         CvDEPTH(multicall_cv)--;                                        \
877         POPBLOCK(cx,PL_curpm);                                          \
878         CATCH_SET(multicall_oldcatch);                                  \
879         LEAVE;                                                          \
880     } STMT_END
881
882 /*
883  * Local variables:
884  * c-indentation-style: bsd
885  * c-basic-offset: 4
886  * indent-tabs-mode: t
887  * End:
888  *
889  * ex: set ts=8 sts=4 sw=4 noet:
890  */