This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
15de02f5164460db9570f297ba180eafadb742d4
[perl5.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, 2007, 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 #include "mydtrace.h"
136
137 struct cop {
138     BASEOP
139     /* On LP64 putting this here takes advantage of the fact that BASEOP isn't
140        an exact multiple of 8 bytes to save structure padding.  */
141     line_t      cop_line;       /* line # of this command */
142     char *      cop_label;      /* label for this construct */
143 #ifdef USE_ITHREADS
144     char *      cop_stashpv;    /* package line was compiled in */
145     char *      cop_file;       /* file name the following line # is from */
146 #else
147     HV *        cop_stash;      /* package line was compiled in */
148     GV *        cop_filegv;     /* file the following line # is from */
149 #endif
150     U32         cop_hints;      /* hints bits from pragmata */
151     U32         cop_seq;        /* parse sequence number */
152     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
153     STRLEN *    cop_warnings;   /* lexical warnings bitmask */
154     /* compile time state of %^H.  See the comment in op.c for how this is
155        used to recreate a hash to return from caller.  */
156     struct refcounted_he * cop_hints_hash;
157 };
158
159 #ifdef USE_ITHREADS
160 #  define CopFILE(c)            ((c)->cop_file)
161 #  define CopFILEGV(c)          (CopFILE(c) \
162                                  ? gv_fetchfile(CopFILE(c)) : NULL)
163                                  
164 #  ifdef NETWARE
165 #    define CopFILE_set(c,pv)   ((c)->cop_file = savepv(pv))
166 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savepv((pv),(l)))
167 #  else
168 #    define CopFILE_set(c,pv)   ((c)->cop_file = savesharedpv(pv))
169 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savesharedpvn((pv),(l)))
170 #  endif
171
172 #  define CopFILESV(c)          (CopFILE(c) \
173                                  ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
174 #  define CopFILEAV(c)          (CopFILE(c) \
175                                  ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
176 #  ifdef DEBUGGING
177 #    define CopFILEAVx(c)       (assert(CopFILE(c)), \
178                                    GvAV(gv_fetchfile(CopFILE(c))))
179 #  else
180 #    define CopFILEAVx(c)       (GvAV(gv_fetchfile(CopFILE(c))))
181 #  endif
182 #  define CopSTASHPV(c)         ((c)->cop_stashpv)
183
184 #  ifdef NETWARE
185 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
186 #  else
187 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = savesharedpv(pv))
188 #  endif
189
190 #  define CopSTASH(c)           (CopSTASHPV(c) \
191                                  ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
192 #  define CopSTASH_set(c,hv)    CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
193 #  define CopSTASH_eq(c,hv)     ((hv) && stashpv_hvname_match(c,hv))
194 #  define CopLABEL(c)           ((c)->cop_label)
195 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
196 #  ifdef NETWARE
197 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
198 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
199 #    define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
200 #    define CopLABEL_alloc(pv)  ((pv)?savepv(pv):NULL)
201 #  else
202 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
203 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
204 #    define CopLABEL_free(c)    (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
205 #    define CopLABEL_alloc(pv)  ((pv)?savesharedpv(pv):NULL)
206 #  endif
207 #else
208 #  define CopFILEGV(c)          ((c)->cop_filegv)
209 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
210 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
211 #  define CopFILE_setn(c,pv,l)  CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
212 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
213 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
214 #  ifdef DEBUGGING
215 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
216 #  else
217 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
218 # endif
219 #  define CopFILE(c)            (CopFILEGV(c) && GvSV(CopFILEGV(c)) \
220                                     ? SvPVX(GvSV(CopFILEGV(c))) : NULL)
221 #  define CopSTASH(c)           ((c)->cop_stash)
222 #  define CopLABEL(c)           ((c)->cop_label)
223 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
224 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
225    /* cop_stash is not refcounted */
226 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
227 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
228 #  define CopLABEL_alloc(pv)    ((pv)?savepv(pv):NULL)
229 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
230 #  define CopSTASH_free(c)      
231 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
232 #  define CopLABEL_free(c)      (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
233
234 #endif /* USE_ITHREADS */
235
236 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
237 #define CopLINE(c)              ((c)->cop_line)
238 #define CopLINE_inc(c)          (++CopLINE(c))
239 #define CopLINE_dec(c)          (--CopLINE(c))
240 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
241
242 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
243 #ifdef MACOS_TRADITIONAL
244 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
245 #else
246 #  define OutCopFILE(c) CopFILE(c)
247 #endif
248
249 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
250    HINT_ARYBASE is set to indicate this.
251    Setting it is ineficient due to the need to create 2 mortal SVs, but as
252    using $[ is highly discouraged, no sane Perl code will be using it.  */
253 #define CopARYBASE_get(c)       \
254         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
255          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
256                                          "$[", 2, 0, 0))                \
257          : 0)
258 #define CopARYBASE_set(c, b) STMT_START { \
259         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
260             (c)->cop_hints |= HINT_ARYBASE;                             \
261             if ((c) == &PL_compiling)                                   \
262                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
263             (c)->cop_hints_hash                                         \
264                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
265                                         newSVpvs_flags("$[", SVs_TEMP), \
266                                         sv_2mortal(newSViv(b)));        \
267         }                                                               \
268     } STMT_END
269
270 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
271 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
272 #define CopHINTS_set(c, h)      STMT_START {                            \
273                                     (c)->cop_hints = (h);               \
274                                 } STMT_END
275
276 /*
277  * Here we have some enormously heavy (or at least ponderous) wizardry.
278  */
279
280 /* subroutine context */
281 struct block_sub {
282     OP *        retop;  /* op to execute on exit from sub */
283     /* Above here is the same for sub, format and eval.  */
284     CV *        cv;
285     /* Above here is the same for sub and format.  */
286     AV *        savearray;
287     AV *        argarray;
288     I32         olddepth;
289     PAD         *oldcomppad;
290 };
291
292
293 /* format context */
294 struct block_format {
295     OP *        retop;  /* op to execute on exit from sub */
296     /* Above here is the same for sub, format and eval.  */
297     CV *        cv;
298     /* Above here is the same for sub and format.  */
299     GV *        gv;
300     GV *        dfoutgv;
301 };
302
303 /* base for the next two macros. Don't use directly.
304  * Note that the refcnt of the cv is incremented twice;  The CX one is
305  * decremented by LEAVESUB, the other by LEAVE. */
306
307 #define PUSHSUB_BASE(cx)                                                \
308         ENTRY_PROBE(GvENAME(CvGV(cv)),                                  \
309                 CopFILE((COP*)CvSTART(cv)),                             \
310                 CopLINE((COP*)CvSTART(cv)));                            \
311                                                                         \
312         cx->blk_sub.cv = cv;                                            \
313         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
314         cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;                     \
315         cx->blk_sub.retop = NULL;                                       \
316         if (!CvDEPTH(cv)) {                                             \
317             SvREFCNT_inc_simple_void_NN(cv);                            \
318             SvREFCNT_inc_simple_void_NN(cv);                            \
319             SAVEFREESV(cv);                                             \
320         }
321
322
323 #define PUSHSUB(cx)                                                     \
324         PUSHSUB_BASE(cx)                                                \
325         cx->blk_u16 = PL_op->op_private &                               \
326                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
327
328 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
329 #define PUSHSUB_DB(cx)                                                  \
330         PUSHSUB_BASE(cx)                                                \
331         cx->blk_u16 = 0;
332
333
334 #define PUSHFORMAT(cx, retop)                                           \
335         cx->blk_format.cv = cv;                                         \
336         cx->blk_format.gv = gv;                                         \
337         cx->blk_format.retop = (retop);                                 \
338         cx->blk_format.dfoutgv = PL_defoutgv;                           \
339         SvREFCNT_inc_void(cx->blk_format.dfoutgv)
340
341 #define POP_SAVEARRAY()                                         \
342     STMT_START {                                                        \
343         SvREFCNT_dec(GvAV(PL_defgv));                                   \
344         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
345     } STMT_END
346
347 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
348  * leave any (a fast av_clear(ary), basically) */
349 #define CLEAR_ARGARRAY(ary) \
350     STMT_START {                                                        \
351         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
352         AvARRAY(ary) = AvALLOC(ary);                                    \
353         AvFILLp(ary) = -1;                                              \
354     } STMT_END
355
356 #define POPSUB(cx,sv)                                                   \
357     STMT_START {                                                        \
358         RETURN_PROBE(GvENAME(CvGV((CV*)cx->blk_sub.cv)),                \
359                 CopFILE((COP*)CvSTART((CV*)cx->blk_sub.cv)),            \
360                 CopLINE((COP*)CvSTART((CV*)cx->blk_sub.cv)));           \
361                                                                         \
362         if (CxHASARGS(cx)) {                                            \
363             POP_SAVEARRAY();                                            \
364             /* abandon @_ if it got reified */                          \
365             if (AvREAL(cx->blk_sub.argarray)) {                         \
366                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
367                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
368                 cx->blk_sub.argarray = newAV();                         \
369                 av_extend(cx->blk_sub.argarray, fill);                  \
370                 AvREIFY_only(cx->blk_sub.argarray);                     \
371                 CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray;       \
372             }                                                           \
373             else {                                                      \
374                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
375             }                                                           \
376         }                                                               \
377         sv = (SV*)cx->blk_sub.cv;                                       \
378         if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))            \
379             sv = NULL;                                          \
380     } STMT_END
381
382 #define LEAVESUB(sv)                                                    \
383     STMT_START {                                                        \
384         if (sv)                                                         \
385             SvREFCNT_dec(sv);                                           \
386     } STMT_END
387
388 #define POPFORMAT(cx)                                                   \
389         setdefout(cx->blk_format.dfoutgv);                              \
390         SvREFCNT_dec(cx->blk_format.dfoutgv);
391
392 /* eval context */
393 struct block_eval {
394     OP *        retop;  /* op to execute on exit from eval */
395     /* Above here is the same for sub, format and eval.  */
396     SV *        old_namesv;
397     OP *        old_eval_root;
398     SV *        cur_text;
399     CV *        cv;
400     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
401 };
402
403 /* If we ever need more than 512 op types, change the shift from 7.
404    blku_gimme is actually also only 2 bits, so could be merged with something.
405 */
406
407 #define CxOLD_IN_EVAL(cx)       (((cx)->blk_u16) & 0x7F)
408 #define CxOLD_OP_TYPE(cx)       (((cx)->blk_u16) >> 7)
409
410 #define PUSHEVAL(cx,n,fgv)                                              \
411     STMT_START {                                                        \
412         assert(!(PL_in_eval & ~0x7F));                                  \
413         assert(!(PL_op->op_type & ~0x1FF));                             \
414         cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); \
415         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
416         cx->blk_eval.old_eval_root = PL_eval_root;                      \
417         cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;  \
418         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
419         cx->blk_eval.retop = NULL;                                      \
420         cx->blk_eval.cur_top_env = PL_top_env;                          \
421     } STMT_END
422
423 #define POPEVAL(cx)                                                     \
424     STMT_START {                                                        \
425         PL_in_eval = CxOLD_IN_EVAL(cx);                                 \
426         optype = CxOLD_OP_TYPE(cx);                                     \
427         PL_eval_root = cx->blk_eval.old_eval_root;                      \
428         if (cx->blk_eval.old_namesv)                                    \
429             sv_2mortal(cx->blk_eval.old_namesv);                        \
430     } STMT_END
431
432 /* loop context */
433 struct block_loop {
434     I32         resetsp;
435     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
436     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
437         why next_op is conditionally defined below.)  */
438 #ifdef USE_ITHREADS
439     void *      iterdata;
440     PAD         *oldcomppad;
441 #else
442     OP *        next_op;
443     SV **       itervar;
444 #endif
445     SV *        itersave;
446     /* (from inspection of source code) for a .. range of strings this is the
447        current string.  */
448     SV *        iterlval;
449     /* (from inspection of source code) for a foreach loop this is the array
450        being iterated over. For a .. range of numbers it's the current value.
451        A check is often made on the SvTYPE of iterary to determine whether
452        we are iterating over an array or a range. (numbers or strings)  */
453     AV *        iterary;
454     IV          iterix;
455     /* (from inspection of source code) for a .. range of numbers this is the
456        maximum value.  */
457     IV          itermax;
458 };
459 /* It might be possible to squeeze this structure further. As best I can tell
460    itermax and iterlval are never used at the same time, so it might be possible
461    to make them into a union. However, I'm not confident that there are enough
462    flag bits/NULLable pointers in this structure alone to encode which is
463    active. There is, however, U8 of space free in struct block, which could be
464    used. Right now it may not be worth squeezing this structure further, as it's
465    the largest part of struct block, and currently struct block is 64 bytes on
466    an ILP32 system, which will give good cache alignment.
467 */
468
469 #ifdef USE_ITHREADS
470 #  define CxITERVAR(c)                                                  \
471         ((c)->blk_loop.iterdata                                         \
472          ? (CxPADLOOP(cx)                                               \
473             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
474                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
475             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
476          : (SV**)NULL)
477 #  define CX_ITERDATA_SET(cx,idata)                                     \
478         CX_CURPAD_SAVE(cx->blk_loop);                                   \
479         if ((cx->blk_loop.iterdata = (idata)))                          \
480             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
481         else                                                            \
482             cx->blk_loop.itersave = NULL;
483 #else
484 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
485 #  define CX_ITERDATA_SET(cx,ivar)                                      \
486         if ((cx->blk_loop.itervar = (SV**)(ivar)))                      \
487             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
488         else                                                            \
489             cx->blk_loop.itersave = NULL;
490 #endif
491 #define CxLABEL(c)      (0 + (c)->blk_oldcop->cop_label)
492 #define CxHASARGS(c)    (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
493 #define CxLVAL(c)       (0 + (c)->blk_u16)
494
495 #ifdef USE_ITHREADS
496 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
497 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
498 #else
499 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
500 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
501 #endif
502
503 #define PUSHLOOP_PLAIN(cx, s)                                           \
504         cx->blk_loop.resetsp = s - PL_stack_base;                       \
505         cx->blk_loop.my_op = cLOOP;                                     \
506         PUSHLOOP_OP_NEXT;                                               \
507         cx->blk_loop.iterlval = NULL;                                   \
508         cx->blk_loop.iterary = NULL;                                    \
509         CX_ITERDATA_SET(cx,NULL);
510
511 #define PUSHLOOP_FOR(cx, dat, s)                                        \
512         cx->blk_loop.resetsp = s - PL_stack_base;                       \
513         cx->blk_loop.my_op = cLOOP;                                     \
514         PUSHLOOP_OP_NEXT;                                               \
515         cx->blk_loop.iterlval = NULL;                                   \
516         cx->blk_loop.iterary = NULL;                                    \
517         cx->blk_loop.iterix = -1;                                       \
518         CX_ITERDATA_SET(cx,dat);
519
520 #define POPLOOP(cx)                                                     \
521         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
522         if (CxITERVAR(cx)) {                                            \
523             if (SvPADMY(cx->blk_loop.itersave)) {                       \
524                 SV ** const s_v_p = CxITERVAR(cx);                      \
525                 sv_2mortal(*s_v_p);                                     \
526                 *s_v_p = cx->blk_loop.itersave;                         \
527             }                                                           \
528             else {                                                      \
529                 SvREFCNT_dec(cx->blk_loop.itersave);                    \
530             }                                                           \
531         }                                                               \
532         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
533             SvREFCNT_dec(cx->blk_loop.iterary);
534
535 /* given/when context */
536 struct block_givwhen {
537         OP *leave_op;
538 };
539
540 #define PUSHGIVEN(cx)                                                   \
541         cx->blk_givwhen.leave_op = cLOGOP->op_other;
542
543 #define PUSHWHEN PUSHGIVEN
544
545 /* context common to subroutines, evals and loops */
546 struct block {
547     U8          blku_type;      /* what kind of context this is */
548     U8          blku_gimme;     /* is this block running in list context? */
549     U16         blku_u16;       /* used by block_sub and block_eval (so far) */
550     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
551     COP *       blku_oldcop;    /* old curcop pointer */
552     I32         blku_oldmarksp; /* mark stack index */
553     I32         blku_oldscopesp;        /* scope stack index */
554     PMOP *      blku_oldpm;     /* values of pattern match vars */
555
556     union {
557         struct block_sub        blku_sub;
558         struct block_format     blku_format;
559         struct block_eval       blku_eval;
560         struct block_loop       blku_loop;
561         struct block_givwhen    blku_givwhen;
562     } blk_u;
563 };
564 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
565 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
566 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
567 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
568 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
569 #define blk_gimme       cx_u.cx_blk.blku_gimme
570 #define blk_u16         cx_u.cx_blk.blku_u16
571 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
572 #define blk_format      cx_u.cx_blk.blk_u.blku_format
573 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
574 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
575 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
576
577 /* Enter a block. */
578 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
579         cx->cx_type             = t,                                    \
580         cx->blk_oldsp           = sp - PL_stack_base,                   \
581         cx->blk_oldcop          = PL_curcop,                            \
582         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
583         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
584         cx->blk_oldpm           = PL_curpm,                             \
585         cx->blk_gimme           = (U8)gimme;                            \
586         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
587                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
588
589 /* Exit a block (RETURN and LAST). */
590 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
591         newsp            = PL_stack_base + cx->blk_oldsp,               \
592         PL_curcop        = cx->blk_oldcop,                              \
593         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
594         PL_scopestack_ix = cx->blk_oldscopesp,                          \
595         pm               = cx->blk_oldpm,                               \
596         gimme            = cx->blk_gimme;                               \
597         DEBUG_SCOPE("POPBLOCK");                                        \
598         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
599                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
600
601 /* Continue a block elsewhere (NEXT and REDO). */
602 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
603         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
604         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
605         PL_scopestack_ix = cx->blk_oldscopesp,                          \
606         PL_curpm         = cx->blk_oldpm;                               \
607         DEBUG_SCOPE("TOPBLOCK");
608
609 /* substitution context */
610 struct subst {
611     U8          sbu_type;       /* what kind of context this is */
612     U8          sbu_rflags;
613     U16         sbu_rxtainted;  /* matches struct block */
614     I32         sbu_iters;
615     I32         sbu_maxiters;
616     I32         sbu_oldsave;
617     char *      sbu_orig;
618     SV *        sbu_dstr;
619     SV *        sbu_targ;
620     char *      sbu_s;
621     char *      sbu_m;
622     char *      sbu_strend;
623     void *      sbu_rxres;
624     REGEXP *    sbu_rx;
625 };
626 #define sb_iters        cx_u.cx_subst.sbu_iters
627 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
628 #define sb_rflags       cx_u.cx_subst.sbu_rflags
629 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
630 #define sb_once         cx_u.cx_subst.sbu_once
631 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
632 #define sb_orig         cx_u.cx_subst.sbu_orig
633 #define sb_dstr         cx_u.cx_subst.sbu_dstr
634 #define sb_targ         cx_u.cx_subst.sbu_targ
635 #define sb_s            cx_u.cx_subst.sbu_s
636 #define sb_m            cx_u.cx_subst.sbu_m
637 #define sb_strend       cx_u.cx_subst.sbu_strend
638 #define sb_rxres        cx_u.cx_subst.sbu_rxres
639 #define sb_rx           cx_u.cx_subst.sbu_rx
640
641 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
642         cx->sb_iters            = iters,                                \
643         cx->sb_maxiters         = maxiters,                             \
644         cx->sb_rflags           = r_flags,                              \
645         cx->sb_oldsave          = oldsave,                              \
646         cx->sb_rxtainted        = rxtainted,                            \
647         cx->sb_orig             = orig,                                 \
648         cx->sb_dstr             = dstr,                                 \
649         cx->sb_targ             = targ,                                 \
650         cx->sb_s                = s,                                    \
651         cx->sb_m                = m,                                    \
652         cx->sb_strend           = strend,                               \
653         cx->sb_rxres            = NULL,                                 \
654         cx->sb_rx               = rx,                                   \
655         cx->cx_type             = CXt_SUBST | (once ? CXp_ONCE : 0);    \
656         rxres_save(&cx->sb_rxres, rx);                                  \
657         (void)ReREFCNT_inc(rx)
658
659 #define CxONCE(cx)              ((cx)->cx_type & CXp_ONCE)
660
661 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
662         rxres_free(&cx->sb_rxres);                                      \
663         ReREFCNT_dec(cx->sb_rx)
664
665 struct context {
666     union {
667         struct block    cx_blk;
668         struct subst    cx_subst;
669     } cx_u;
670 };
671 #define cx_type cx_u.cx_subst.sbu_type
672
673 #define CXTYPEMASK      0xf
674 #define CXt_NULL        0
675 #define CXt_SUB         1
676 #define CXt_EVAL        2
677 #define CXt_WHEN        3
678 #define CXt_SUBST       4
679 #define CXt_BLOCK       5
680 #define CXt_FORMAT      6
681 #define CXt_GIVEN       7
682 #define CXt_LOOP_PLAIN  8
683 #define CXt_LOOP_FOR    9
684 #define CXt_LOOP_RES1   10
685 #define CXt_LOOP_RES2   11
686
687 /* private flags for CXt_SUB and CXt_NULL
688    However, this is checked in many places which do not check the type, so
689    this bit needs to be kept clear for most everything else. For reasons I
690    haven't investigated, it can coexist with CXp_FOR_DEF */
691 #define CXp_MULTICALL   0x10    /* part of a multicall (so don't
692                                    tear down context on exit). */ 
693
694 /* private flags for CXt_SUB and CXt_FORMAT */
695 #define CXp_HASARGS     0x20
696
697 /* private flags for CXt_EVAL */
698 #define CXp_REAL        0x20    /* truly eval'', not a lookalike */
699 #define CXp_TRYBLOCK    0x40    /* eval{}, not eval'' or similar */
700
701 /* private flags for CXt_LOOP */
702 #define CXp_FOR_DEF     0x10    /* foreach using $_ */
703 #ifdef USE_ITHREADS
704 #  define CXp_PADVAR    0x20    /* itervar lives on pad, iterdata has pad
705                                    offset; if not set, iterdata holds GV* */
706 #  define CxPADLOOP(c)  (CxTYPE_is_LOOP(c) && ((c)->cx_type & (CXp_PADVAR)))
707 #endif
708 /* private flags for CXt_SUBST */
709 #define CXp_ONCE        0x10    /* What was sbu_once in struct subst */
710
711 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
712 #define CxTYPE_is_LOOP(c)       (((c)->cx_type & 0xC) == 0x8)
713 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
714                          == CXp_MULTICALL)
715 #define CxREALEVAL(c)   (((c)->cx_type & (CXTYPEMASK|CXp_REAL))         \
716                          == (CXt_EVAL|CXp_REAL))
717 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK))     \
718                          == (CXt_EVAL|CXp_TRYBLOCK))
719 #define CxFOREACH(c)    (CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN)
720 #define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \
721                          && ((c)->cx_type & CXp_FOR_DEF))
722
723 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
724
725 /* 
726 =head1 "Gimme" Values
727 */
728
729 /*
730 =for apidoc AmU||G_SCALAR
731 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
732 L<perlcall>.
733
734 =for apidoc AmU||G_ARRAY
735 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
736 L<perlcall>.
737
738 =for apidoc AmU||G_VOID
739 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
740
741 =for apidoc AmU||G_DISCARD
742 Indicates that arguments returned from a callback should be discarded.  See
743 L<perlcall>.
744
745 =for apidoc AmU||G_EVAL
746
747 Used to force a Perl C<eval> wrapper around a callback.  See
748 L<perlcall>.
749
750 =for apidoc AmU||G_NOARGS
751
752 Indicates that no arguments are being sent to a callback.  See
753 L<perlcall>.
754
755 =cut
756 */
757
758 #define G_SCALAR        2
759 #define G_ARRAY         3
760 #define G_VOID          1
761 #define G_WANT          3
762
763 /* extra flags for Perl_call_* routines */
764 #define G_DISCARD       4       /* Call FREETMPS.
765                                    Don't change this without consulting the
766                                    hash actions codes defined in hv.h */
767 #define G_EVAL          8       /* Assume eval {} around subroutine call. */
768 #define G_NOARGS       16       /* Don't construct a @_ array. */
769 #define G_KEEPERR      32       /* Append errors to $@, don't overwrite it */
770 #define G_NODEBUG      64       /* Disable debugging at toplevel.  */
771 #define G_METHOD      128       /* Calling method. */
772 #define G_FAKINGEVAL  256       /* Faking an eval context for call_sv or
773                                    fold_constants. */
774
775 /* flag bits for PL_in_eval */
776 #define EVAL_NULL       0       /* not in an eval */
777 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
778 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
779 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
780 #define EVAL_INREQUIRE  8       /* The code is being required. */
781
782 /* Support for switching (stack and block) contexts.
783  * This ensures magic doesn't invalidate local stack and cx pointers.
784  */
785
786 #define PERLSI_UNKNOWN          -1
787 #define PERLSI_UNDEF            0
788 #define PERLSI_MAIN             1
789 #define PERLSI_MAGIC            2
790 #define PERLSI_SORT             3
791 #define PERLSI_SIGNAL           4
792 #define PERLSI_OVERLOAD         5
793 #define PERLSI_DESTROY          6
794 #define PERLSI_WARNHOOK         7
795 #define PERLSI_DIEHOOK          8
796 #define PERLSI_REQUIRE          9
797
798 struct stackinfo {
799     AV *                si_stack;       /* stack for current runlevel */
800     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
801     struct stackinfo *  si_prev;
802     struct stackinfo *  si_next;
803     I32                 si_cxix;        /* current context index */
804     I32                 si_cxmax;       /* maximum allocated index */
805     I32                 si_type;        /* type of runlevel */
806     I32                 si_markoff;     /* offset where markstack begins for us.
807                                          * currently used only with DEBUGGING,
808                                          * but not #ifdef-ed for bincompat */
809 };
810
811 typedef struct stackinfo PERL_SI;
812
813 #define cxstack         (PL_curstackinfo->si_cxstack)
814 #define cxstack_ix      (PL_curstackinfo->si_cxix)
815 #define cxstack_max     (PL_curstackinfo->si_cxmax)
816
817 #ifdef DEBUGGING
818 #  define       SET_MARK_OFFSET \
819     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
820 #else
821 #  define       SET_MARK_OFFSET NOOP
822 #endif
823
824 #define PUSHSTACKi(type) \
825     STMT_START {                                                        \
826         PERL_SI *next = PL_curstackinfo->si_next;                       \
827         if (!next) {                                                    \
828             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
829             next->si_prev = PL_curstackinfo;                            \
830             PL_curstackinfo->si_next = next;                            \
831         }                                                               \
832         next->si_type = type;                                           \
833         next->si_cxix = -1;                                             \
834         AvFILLp(next->si_stack) = 0;                                    \
835         SWITCHSTACK(PL_curstack,next->si_stack);                        \
836         PL_curstackinfo = next;                                         \
837         SET_MARK_OFFSET;                                                \
838     } STMT_END
839
840 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
841
842 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
843  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
844 #define POPSTACK \
845     STMT_START {                                                        \
846         dSP;                                                            \
847         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
848         if (!prev) {                                                    \
849             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
850             my_exit(1);                                                 \
851         }                                                               \
852         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
853         /* don't free prev here, free them all at the END{} */          \
854         PL_curstackinfo = prev;                                         \
855     } STMT_END
856
857 #define POPSTACK_TO(s) \
858     STMT_START {                                                        \
859         while (PL_curstack != s) {                                      \
860             dounwind(-1);                                               \
861             POPSTACK;                                                   \
862         }                                                               \
863     } STMT_END
864
865 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
866 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
867
868 /*
869 =head1 Multicall Functions
870
871 =for apidoc Ams||dMULTICALL
872 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
873
874 =for apidoc Ams||PUSH_MULTICALL
875 Opening bracket for a lightweight callback.
876 See L<perlcall/Lightweight Callbacks>.
877
878 =for apidoc Ams||MULTICALL
879 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
880
881 =for apidoc Ams||POP_MULTICALL
882 Closing bracket for a lightweight callback.
883 See L<perlcall/Lightweight Callbacks>.
884
885 =cut
886 */
887
888 #define dMULTICALL \
889     SV **newsp;                 /* set by POPBLOCK */                   \
890     PERL_CONTEXT *cx;                                                   \
891     CV *multicall_cv;                                                   \
892     OP *multicall_cop;                                                  \
893     bool multicall_oldcatch;                                            \
894     U8 hasargs = 0              /* used by PUSHSUB */
895
896 #define PUSH_MULTICALL(the_cv) \
897     STMT_START {                                                        \
898         CV * const _nOnclAshIngNamE_ = the_cv;                          \
899         CV * const cv = _nOnclAshIngNamE_;                              \
900         AV * const padlist = CvPADLIST(cv);                             \
901         ENTER;                                                          \
902         multicall_oldcatch = CATCH_GET;                                 \
903         SAVETMPS; SAVEVPTR(PL_op);                                      \
904         CATCH_SET(TRUE);                                                \
905         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
906         PUSHSUB(cx);                                                    \
907         if (++CvDEPTH(cv) >= 2) {                                       \
908             PERL_STACK_OVERFLOW_CHECK();                                \
909             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
910         }                                                               \
911         SAVECOMPPAD();                                                  \
912         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
913         multicall_cv = cv;                                              \
914         multicall_cop = CvSTART(cv);                                    \
915     } STMT_END
916
917 #define MULTICALL \
918     STMT_START {                                                        \
919         PL_op = multicall_cop;                                          \
920         CALLRUNOPS(aTHX);                                               \
921     } STMT_END
922
923 #define POP_MULTICALL \
924     STMT_START {                                                        \
925         LEAVESUB(multicall_cv);                                         \
926         CvDEPTH(multicall_cv)--;                                        \
927         POPBLOCK(cx,PL_curpm);                                          \
928         CATCH_SET(multicall_oldcatch);                                  \
929         LEAVE;                                                          \
930     } STMT_END
931
932 /*
933  * Local variables:
934  * c-indentation-style: bsd
935  * c-basic-offset: 4
936  * indent-tabs-mode: t
937  * End:
938  *
939  * ex: set ts=8 sts=4 sw=4 noet:
940  */