CoreList: fix release date on v5.24.0
[perl.git] / inline.h
1 /*    inline.h
2  *
3  *    Copyright (C) 2012 by Larry Wall and others
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  * This file is a home for static inline functions that cannot go in other
9  * headers files, because they depend on proto.h (included after most other
10  * headers) or struct definitions.
11  *
12  * Each section names the header file that the functions "belong" to.
13  */
14
15 /* ------------------------------- av.h ------------------------------- */
16
17 PERL_STATIC_INLINE SSize_t
18 S_av_top_index(pTHX_ AV *av)
19 {
20     PERL_ARGS_ASSERT_AV_TOP_INDEX;
21     assert(SvTYPE(av) == SVt_PVAV);
22
23     return AvFILL(av);
24 }
25
26 /* ------------------------------- cv.h ------------------------------- */
27
28 PERL_STATIC_INLINE GV *
29 S_CvGV(pTHX_ CV *sv)
30 {
31     return CvNAMED(sv)
32         ? Perl_cvgv_from_hek(aTHX_ sv)
33         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
34 }
35
36 PERL_STATIC_INLINE I32 *
37 S_CvDEPTHp(const CV * const sv)
38 {
39     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
40     return &((XPVCV*)SvANY(sv))->xcv_depth;
41 }
42
43 /*
44  CvPROTO returns the prototype as stored, which is not necessarily what
45  the interpreter should be using. Specifically, the interpreter assumes
46  that spaces have been stripped, which has been the case if the prototype
47  was added by toke.c, but is generally not the case if it was added elsewhere.
48  Since we can't enforce the spacelessness at assignment time, this routine
49  provides a temporary copy at parse time with spaces removed.
50  I<orig> is the start of the original buffer, I<len> is the length of the
51  prototype and will be updated when this returns.
52  */
53
54 #ifdef PERL_CORE
55 PERL_STATIC_INLINE char *
56 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
57 {
58     SV * tmpsv;
59     char * tmps;
60     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
61     tmps = SvPVX(tmpsv);
62     while ((*len)--) {
63         if (!isSPACE(*orig))
64             *tmps++ = *orig;
65         orig++;
66     }
67     *tmps = '\0';
68     *len = tmps - SvPVX(tmpsv);
69                 return SvPVX(tmpsv);
70 }
71 #endif
72
73 /* ------------------------------- mg.h ------------------------------- */
74
75 #if defined(PERL_CORE) || defined(PERL_EXT)
76 /* assumes get-magic and stringification have already occurred */
77 PERL_STATIC_INLINE STRLEN
78 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
79 {
80     assert(mg->mg_type == PERL_MAGIC_regex_global);
81     assert(mg->mg_len != -1);
82     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
83         return (STRLEN)mg->mg_len;
84     else {
85         const STRLEN pos = (STRLEN)mg->mg_len;
86         /* Without this check, we may read past the end of the buffer: */
87         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
88         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
89     }
90 }
91 #endif
92
93 /* ------------------------------- pad.h ------------------------------ */
94
95 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96 PERL_STATIC_INLINE bool
97 PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
98 {
99     /* is seq within the range _LOW to _HIGH ?
100      * This is complicated by the fact that PL_cop_seqmax
101      * may have wrapped around at some point */
102     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
103         return FALSE; /* not yet introduced */
104
105     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
106     /* in compiling scope */
107         if (
108             (seq >  COP_SEQ_RANGE_LOW(pn))
109             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
110             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
111         )
112             return TRUE;
113     }
114     else if (
115         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
116         ?
117             (  seq >  COP_SEQ_RANGE_LOW(pn)
118             || seq <= COP_SEQ_RANGE_HIGH(pn))
119
120         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
121              && seq <= COP_SEQ_RANGE_HIGH(pn))
122     )
123         return TRUE;
124     return FALSE;
125 }
126 #endif
127
128 /* ----------------------------- regexp.h ----------------------------- */
129
130 PERL_STATIC_INLINE struct regexp *
131 S_ReANY(const REGEXP * const re)
132 {
133     assert(isREGEXP(re));
134     return re->sv_u.svu_rx;
135 }
136
137 /* ------------------------------- sv.h ------------------------------- */
138
139 PERL_STATIC_INLINE SV *
140 S_SvREFCNT_inc(SV *sv)
141 {
142     if (LIKELY(sv != NULL))
143         SvREFCNT(sv)++;
144     return sv;
145 }
146 PERL_STATIC_INLINE SV *
147 S_SvREFCNT_inc_NN(SV *sv)
148 {
149     SvREFCNT(sv)++;
150     return sv;
151 }
152 PERL_STATIC_INLINE void
153 S_SvREFCNT_inc_void(SV *sv)
154 {
155     if (LIKELY(sv != NULL))
156         SvREFCNT(sv)++;
157 }
158 PERL_STATIC_INLINE void
159 S_SvREFCNT_dec(pTHX_ SV *sv)
160 {
161     if (LIKELY(sv != NULL)) {
162         U32 rc = SvREFCNT(sv);
163         if (LIKELY(rc > 1))
164             SvREFCNT(sv) = rc - 1;
165         else
166             Perl_sv_free2(aTHX_ sv, rc);
167     }
168 }
169
170 PERL_STATIC_INLINE void
171 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
172 {
173     U32 rc = SvREFCNT(sv);
174     if (LIKELY(rc > 1))
175         SvREFCNT(sv) = rc - 1;
176     else
177         Perl_sv_free2(aTHX_ sv, rc);
178 }
179
180 PERL_STATIC_INLINE void
181 SvAMAGIC_on(SV *sv)
182 {
183     assert(SvROK(sv));
184     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
185 }
186 PERL_STATIC_INLINE void
187 SvAMAGIC_off(SV *sv)
188 {
189     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
190         HvAMAGIC_off(SvSTASH(SvRV(sv)));
191 }
192
193 PERL_STATIC_INLINE U32
194 S_SvPADSTALE_on(SV *sv)
195 {
196     assert(!(SvFLAGS(sv) & SVs_PADTMP));
197     return SvFLAGS(sv) |= SVs_PADSTALE;
198 }
199 PERL_STATIC_INLINE U32
200 S_SvPADSTALE_off(SV *sv)
201 {
202     assert(!(SvFLAGS(sv) & SVs_PADTMP));
203     return SvFLAGS(sv) &= ~SVs_PADSTALE;
204 }
205 #if defined(PERL_CORE) || defined (PERL_EXT)
206 PERL_STATIC_INLINE STRLEN
207 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
208 {
209     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
210     if (SvGAMAGIC(sv)) {
211         U8 *hopped = utf8_hop((U8 *)pv, pos);
212         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
213         return (STRLEN)(hopped - (U8 *)pv);
214     }
215     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
216 }
217 #endif
218
219 /* ------------------------------- handy.h ------------------------------- */
220
221 /* saves machine code for a common noreturn idiom typically used in Newx*() */
222 #ifdef GCC_DIAG_PRAGMA
223 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
224 #endif
225 static void
226 S_croak_memory_wrap(void)
227 {
228     Perl_croak_nocontext("%s",PL_memory_wrap);
229 }
230 #ifdef GCC_DIAG_PRAGMA
231 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
232 #endif
233
234 /* ------------------------------- utf8.h ------------------------------- */
235
236 PERL_STATIC_INLINE void
237 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
238 {
239     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
240      * encoded string at '*dest', updating '*dest' to include it */
241
242     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
243
244     if (NATIVE_BYTE_IS_INVARIANT(byte))
245         *(*dest)++ = byte;
246     else {
247         *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
248         *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
249     }
250 }
251
252 /*
253
254 A helper function for the macro isUTF8_CHAR(), which should be used instead of
255 this function.  The macro will handle smaller code points directly saving time,
256 using this function as a fall-back for higher code points.
257
258 Tests if the first bytes of string C<s> form a valid UTF-8 character.  0 is
259 returned if the bytes starting at C<s> up to but not including C<e> do not form a
260 complete well-formed UTF-8 character; otherwise the number of bytes in the
261 character is returned.
262
263 Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
264 character.
265
266 =cut */
267 PERL_STATIC_INLINE STRLEN
268 S__is_utf8_char_slow(const U8 *s, const U8 *e)
269 {
270     dTHX;   /* The function called below requires thread context */
271
272     STRLEN actual_len;
273
274     PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW;
275
276     assert(e >= s);
277     utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
278
279     return (actual_len == (STRLEN) -1) ? 0 : actual_len;
280 }
281
282 /* ------------------------------- perl.h ----------------------------- */
283
284 /*
285 =head1 Miscellaneous Functions
286
287 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
288
289 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
290 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
291
292 Return TRUE if the name is safe.
293
294 Used by the C<IS_SAFE_SYSCALL()> macro.
295
296 =cut
297 */
298
299 PERL_STATIC_INLINE bool
300 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
301     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
302      * perl itself uses xce*() functions which accept 8-bit strings.
303      */
304
305     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
306
307     if (len > 1) {
308         char *null_at;
309         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
310                 SETERRNO(ENOENT, LIB_INVARG);
311                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
312                                    "Invalid \\0 character in %s for %s: %s\\0%s",
313                                    what, op_name, pv, null_at+1);
314                 return FALSE;
315         }
316     }
317
318     return TRUE;
319 }
320
321 /*
322
323 Return true if the supplied filename has a newline character
324 immediately before the first (hopefully only) NUL.
325
326 My original look at this incorrectly used the len from SvPV(), but
327 that's incorrect, since we allow for a NUL in pv[len-1].
328
329 So instead, strlen() and work from there.
330
331 This allow for the user reading a filename, forgetting to chomp it,
332 then calling:
333
334   open my $foo, "$file\0";
335
336 */
337
338 #ifdef PERL_CORE
339
340 PERL_STATIC_INLINE bool
341 S_should_warn_nl(const char *pv) {
342     STRLEN len;
343
344     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
345
346     len = strlen(pv);
347
348     return len > 0 && pv[len-1] == '\n';
349 }
350
351 #endif
352
353 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
354
355 #define MAX_CHARSET_NAME_LENGTH 2
356
357 PERL_STATIC_INLINE const char *
358 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
359 {
360     /* Returns a string that corresponds to the name of the regex character set
361      * given by 'flags', and *lenp is set the length of that string, which
362      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
363
364     *lenp = 1;
365     switch (get_regex_charset(flags)) {
366         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
367         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
368         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
369         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
370         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
371             *lenp = 2;
372             return ASCII_MORE_RESTRICT_PAT_MODS;
373     }
374     /* The NOT_REACHED; hides an assert() which has a rather complex
375      * definition in perl.h. */
376     NOT_REACHED; /* NOTREACHED */
377     return "?";     /* Unknown */
378 }
379
380 /*
381
382 Return false if any get magic is on the SV other than taint magic.
383
384 */
385
386 PERL_STATIC_INLINE bool
387 S_sv_only_taint_gmagic(SV *sv) {
388     MAGIC *mg = SvMAGIC(sv);
389
390     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
391
392     while (mg) {
393         if (mg->mg_type != PERL_MAGIC_taint
394             && !(mg->mg_flags & MGf_GSKIP)
395             && mg->mg_virtual->svt_get) {
396             return FALSE;
397         }
398         mg = mg->mg_moremagic;
399     }
400
401     return TRUE;
402 }
403
404 /* ------------------ cop.h ------------------------------------------- */
405
406
407 /* Enter a block. Push a new base context and return its address. */
408
409 PERL_STATIC_INLINE PERL_CONTEXT *
410 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
411 {
412     PERL_CONTEXT * cx;
413
414     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
415
416     CXINC;
417     cx = CX_CUR();
418     cx->cx_type        = type;
419     cx->blk_gimme      = gimme;
420     cx->blk_oldsaveix  = saveix;
421     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
422     cx->blk_oldcop     = PL_curcop;
423     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
424     cx->blk_oldscopesp = PL_scopestack_ix;
425     cx->blk_oldpm      = PL_curpm;
426     cx->blk_old_tmpsfloor = PL_tmps_floor;
427
428     PL_tmps_floor        = PL_tmps_ix;
429     CX_DEBUG(cx, "PUSH");
430     return cx;
431 }
432
433
434 /* Exit a block (RETURN and LAST). */
435
436 PERL_STATIC_INLINE void
437 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
438 {
439     PERL_ARGS_ASSERT_CX_POPBLOCK;
440
441     CX_DEBUG(cx, "POP");
442     /* these 3 are common to cx_popblock and cx_topblock */
443     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
444     PL_scopestack_ix = cx->blk_oldscopesp;
445     PL_curpm         = cx->blk_oldpm;
446
447     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
448      * and leaves a CX entry lying around for repeated use, so
449      * skip for multicall */                  \
450     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
451             || PL_savestack_ix == cx->blk_oldsaveix);
452     PL_curcop     = cx->blk_oldcop;
453     PL_tmps_floor = cx->blk_old_tmpsfloor;
454 }
455
456 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
457  * Whereas cx_popblock() restores the state to the point just before
458  * cx_pushblock() was called,  cx_topblock() restores it to the point just
459  * *after* cx_pushblock() was called. */
460
461 PERL_STATIC_INLINE void
462 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
463 {
464     PERL_ARGS_ASSERT_CX_TOPBLOCK;
465
466     CX_DEBUG(cx, "TOP");
467     /* these 3 are common to cx_popblock and cx_topblock */
468     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
469     PL_scopestack_ix = cx->blk_oldscopesp;
470     PL_curpm         = cx->blk_oldpm;
471
472     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
473 }
474
475
476 PERL_STATIC_INLINE void
477 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
478 {
479     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
480
481     PERL_ARGS_ASSERT_CX_PUSHSUB;
482
483     PERL_DTRACE_PROBE_ENTRY(cv);
484     cx->blk_sub.cv = cv;
485     cx->blk_sub.olddepth = CvDEPTH(cv);
486     cx->blk_sub.prevcomppad = PL_comppad;
487     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
488     cx->blk_sub.retop = retop;
489     SvREFCNT_inc_simple_void_NN(cv);
490     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
491 }
492
493
494 /* subsets of cx_popsub() */
495
496 PERL_STATIC_INLINE void
497 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
498 {
499     CV *cv;
500
501     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
502     assert(CxTYPE(cx) == CXt_SUB);
503
504     PL_comppad = cx->blk_sub.prevcomppad;
505     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
506     cv = cx->blk_sub.cv;
507     CvDEPTH(cv) = cx->blk_sub.olddepth;
508     cx->blk_sub.cv = NULL;
509     SvREFCNT_dec(cv);
510 }
511
512
513 /* handle the @_ part of leaving a sub */
514
515 PERL_STATIC_INLINE void
516 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
517 {
518     AV *av;
519
520     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
521     assert(CxTYPE(cx) == CXt_SUB);
522     assert(AvARRAY(MUTABLE_AV(
523         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
524                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
525
526     CX_POP_SAVEARRAY(cx);
527     av = MUTABLE_AV(PAD_SVl(0));
528     if (UNLIKELY(AvREAL(av)))
529         /* abandon @_ if it got reified */
530         clear_defarray(av, 0);
531     else {
532         CLEAR_ARGARRAY(av);
533     }
534 }
535
536
537 PERL_STATIC_INLINE void
538 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
539 {
540     PERL_ARGS_ASSERT_CX_POPSUB;
541     assert(CxTYPE(cx) == CXt_SUB);
542
543     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
544
545     if (CxHASARGS(cx))
546         cx_popsub_args(cx);
547     cx_popsub_common(cx);
548 }
549
550
551 PERL_STATIC_INLINE void
552 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
553 {
554     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
555
556     cx->blk_format.cv          = cv;
557     cx->blk_format.retop       = retop;
558     cx->blk_format.gv          = gv;
559     cx->blk_format.dfoutgv     = PL_defoutgv;
560     cx->blk_format.prevcomppad = PL_comppad;
561     cx->blk_u16                = 0;
562
563     SvREFCNT_inc_simple_void_NN(cv);
564     CvDEPTH(cv)++;
565     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
566 }
567
568
569 PERL_STATIC_INLINE void
570 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
571 {
572     CV *cv;
573     GV *dfout;
574
575     PERL_ARGS_ASSERT_CX_POPFORMAT;
576     assert(CxTYPE(cx) == CXt_FORMAT);
577
578     dfout = cx->blk_format.dfoutgv;
579     setdefout(dfout);
580     cx->blk_format.dfoutgv = NULL;
581     SvREFCNT_dec_NN(dfout);
582
583     PL_comppad = cx->blk_format.prevcomppad;
584     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
585     cv = cx->blk_format.cv;
586     cx->blk_format.cv = NULL;
587     --CvDEPTH(cv);
588     SvREFCNT_dec_NN(cv);
589 }
590
591
592 PERL_STATIC_INLINE void
593 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
594 {
595     PERL_ARGS_ASSERT_CX_PUSHEVAL;
596
597     cx->blk_eval.retop         = retop;
598     cx->blk_eval.old_namesv    = namesv;
599     cx->blk_eval.old_eval_root = PL_eval_root;
600     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
601     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
602     cx->blk_eval.cur_top_env   = PL_top_env;
603
604     assert(!(PL_in_eval     & ~ 0x7F));
605     assert(!(PL_op->op_type & ~0x1FF));
606     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
607 }
608
609
610 PERL_STATIC_INLINE void
611 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
612 {
613     SV *sv;
614
615     PERL_ARGS_ASSERT_CX_POPEVAL;
616     assert(CxTYPE(cx) == CXt_EVAL);
617
618     PL_in_eval = CxOLD_IN_EVAL(cx);
619     PL_eval_root = cx->blk_eval.old_eval_root;
620     sv = cx->blk_eval.cur_text;
621     if (sv && SvSCREAM(sv)) {
622         cx->blk_eval.cur_text = NULL;
623         SvREFCNT_dec_NN(sv);
624     }
625
626     sv = cx->blk_eval.old_namesv;
627     if (sv && !SvTEMP(sv))/* TEMP implies cx_popeval() re-entrantly called */
628         sv_2mortal(sv);
629 }
630
631
632 /* push a plain loop, i.e.
633  *     { block }
634  *     while (cond) { block }
635  *     for (init;cond;continue) { block }
636  * This loop can be last/redo'ed etc.
637  */
638
639 PERL_STATIC_INLINE void
640 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
641 {
642     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
643     cx->blk_loop.my_op = cLOOP;
644 }
645
646
647 /* push a true for loop, i.e.
648  *     for var (list) { block }
649  */
650
651 PERL_STATIC_INLINE void
652 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
653 {
654     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
655
656     /* this one line is common with cx_pushloop_plain */
657     cx->blk_loop.my_op = cLOOP;
658
659     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
660     cx->blk_loop.itersave      = itersave;
661 #ifdef USE_ITHREADS
662     cx->blk_loop.oldcomppad = PL_comppad;
663 #endif
664 }
665
666
667 /* pop all loop types, including plain */
668
669 PERL_STATIC_INLINE void
670 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
671 {
672     PERL_ARGS_ASSERT_CX_POPLOOP;
673
674     assert(CxTYPE_is_LOOP(cx));
675     if (  CxTYPE(cx) == CXt_LOOP_ARY
676        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
677     {
678         /* Free ary or cur. This assumes that state_u.ary.ary
679          * aligns with state_u.lazysv.cur. See cx_dup() */
680         SV *sv = cx->blk_loop.state_u.lazysv.cur;
681         cx->blk_loop.state_u.lazysv.cur = NULL;
682         SvREFCNT_dec_NN(sv);
683         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
684             sv = cx->blk_loop.state_u.lazysv.end;
685             cx->blk_loop.state_u.lazysv.end = NULL;
686             SvREFCNT_dec_NN(sv);
687         }
688     }
689     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
690         SV *cursv;
691         SV **svp = (cx)->blk_loop.itervar_u.svp;
692         if ((cx->cx_type & CXp_FOR_GV))
693             svp = &GvSV((GV*)svp);
694         cursv = *svp;
695         *svp = cx->blk_loop.itersave;
696         cx->blk_loop.itersave = NULL;
697         SvREFCNT_dec(cursv);
698     }
699 }
700
701
702 PERL_STATIC_INLINE void
703 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
704 {
705     PERL_ARGS_ASSERT_CX_PUSHWHEN;
706
707     cx->blk_givwhen.leave_op = cLOGOP->op_other;
708 }
709
710
711 PERL_STATIC_INLINE void
712 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
713 {
714     PERL_ARGS_ASSERT_CX_POPWHEN;
715     assert(CxTYPE(cx) == CXt_WHEN);
716
717     PERL_UNUSED_ARG(cx);
718     /* currently NOOP */
719 }
720
721
722 PERL_STATIC_INLINE void
723 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
724 {
725     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
726
727     cx->blk_givwhen.leave_op = cLOGOP->op_other;
728     cx->blk_givwhen.defsv_save = orig_defsv;
729 }
730
731
732 PERL_STATIC_INLINE void
733 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
734 {
735     SV *sv;
736
737     PERL_ARGS_ASSERT_CX_POPGIVEN;
738     assert(CxTYPE(cx) == CXt_GIVEN);
739
740     sv = GvSV(PL_defgv);
741     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
742     cx->blk_givwhen.defsv_save = NULL;
743     SvREFCNT_dec(sv);
744 }
745
746
747
748
749 /*
750  * ex: set ts=8 sts=4 sw=4 et:
751  */