perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	/* cop.h
	2	*
	3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
	4	* 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 two ops OP_NEXTSTATE and OP_DBSTATE,
	10	* that (loosely speaking) are statement separators.
	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 PL_start_env initialized when perl starts, and
	18	* PL_top_env points to this initially, so PL_top_env should always be
	19	* non-null.
	20	*
	21	* Existence of a non-null PL_top_env->je_prev implies it is valid to call
	22	* longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
	23	* null to ensure this).
	24	*
	25	* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
	26	* establish a local jmpenv to handle exception traps. Care must be taken
	27	* to restore the previous value of je_mustcatch before exiting the
	28	* stack frame iff JMPENV_PUSH was not called in that stack frame.
	29	* GSAR 97-03-27
	30	*/
	31
	32	struct jmpenv {
	33	struct jmpenv * je_prev;
	34	Sigjmp_buf je_buf; /* uninit if je_prev is NULL */
	35	int je_ret; /* last exception thrown */
	36	bool je_mustcatch; /* need to call longjmp()? */
	37	U16 je_old_delaymagic; /* saved PL_delaymagic */
	38	};
	39
	40	typedef struct jmpenv JMPENV;
	41
	42	/*
	43	* How to build the first jmpenv.
	44	*
	45	* top_env needs to be non-zero. It points to an area
	46	* in which longjmp() stuff is stored, as C callstack
	47	* info there at least is thread specific this has to
	48	* be per-thread. Otherwise a 'die' in a thread gives
	49	* that thread the C stack of last thread to do an eval {}!
	50	*/
	51
	52	#define JMPENV_BOOTSTRAP \
	53	STMT_START { \
	54	PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\
	55	PL_top_env = &PL_start_env; \
	56	PL_start_env.je_prev = NULL; \
	57	PL_start_env.je_ret = -1; \
	58	PL_start_env.je_mustcatch = TRUE; \
	59	PL_start_env.je_old_delaymagic = 0; \
	60	} STMT_END
	61
	62	/*
	63	* PERL_FLEXIBLE_EXCEPTIONS
	64	*
	65	* All the flexible exceptions code has been removed.
	66	* See the following threads for details:
	67	*
	68	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
	69	*
	70	* Joshua's original patches (which weren't applied) and discussion:
	71	*
	72	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
	73	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
	74	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
	75	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
	76	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
	77	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
	78	*
	79	* Chip's reworked patch and discussion:
	80	*
	81	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
	82	*
	83	* The flaw in these patches (which went unnoticed at the time) was
	84	* that they moved some code that could potentially die() out of the
	85	* region protected by the setjmp()s. This caused exceptions within
	86	* END blocks and such to not be handled by the correct setjmp().
	87	*
	88	* The original patches that introduces flexible exceptions were:
	89	*
	90	* http://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
	91	* http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
	92	*
	93	*/
	94
	95	#define dJMPENV JMPENV cur_env
	96
	97	#define JMPENV_PUSH(v) \
	98	STMT_START { \
	99	DEBUG_l({ \
	100	int i = 0; JMPENV *p = PL_top_env; \
	101	while (p) { i++; p = p->je_prev; } \
	102	Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
	103	i, __FILE__, __LINE__);}) \
	104	cur_env.je_prev = PL_top_env; \
	105	cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
	106	PL_top_env = &cur_env; \
	107	cur_env.je_mustcatch = FALSE; \
	108	cur_env.je_old_delaymagic = PL_delaymagic; \
	109	(v) = cur_env.je_ret; \
	110	} STMT_END
	111
	112	#define JMPENV_POP \
	113	STMT_START { \
	114	DEBUG_l({ \
	115	int i = -1; JMPENV *p = PL_top_env; \
	116	while (p) { i++; p = p->je_prev; } \
	117	Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
	118	i, __FILE__, __LINE__);}) \
	119	assert(PL_top_env == &cur_env); \
	120	PL_delaymagic = cur_env.je_old_delaymagic; \
	121	PL_top_env = cur_env.je_prev; \
	122	} STMT_END
	123
	124	#define JMPENV_JUMP(v) \
	125	STMT_START { \
	126	DEBUG_l({ \
	127	int i = -1; JMPENV *p = PL_top_env; \
	128	while (p) { i++; p = p->je_prev; } \
	129	Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
	130	(int)v, i, __FILE__, __LINE__);}) \
	131	if (PL_top_env->je_prev) \
	132	PerlProc_longjmp(PL_top_env->je_buf, (v)); \
	133	if ((v) == 2) \
	134	PerlProc_exit(STATUS_EXIT); \
	135	PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
	136	PerlProc_exit(1); \
	137	} STMT_END
	138
	139	#define CATCH_GET (PL_top_env->je_mustcatch)
	140	#define CATCH_SET(v) \
	141	STMT_START { \
	142	DEBUG_l( \
	143	Perl_deb(aTHX_ \
	144	"JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
	145	PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
	146	__FILE__, __LINE__);) \
	147	PL_top_env->je_mustcatch = (v); \
	148	} STMT_END
	149
	150	/*
	151	=head1 COP Hint Hashes
	152	*/
	153
	154	typedef struct refcounted_he COPHH;
	155
	156	#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8
	157
	158	/*
	159	=for apidoc Amx\|SV \|cophh_fetch_pvn\|const COPHH cophh\|const char *keypv\|STRLEN keylen\|U32 hash\|U32 flags
	160
	161	Look up the entry in the cop hints hash C<cophh> with the key specified by
	162	C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
	163	the key octets are interpreted as UTF-8, otherwise they are interpreted
	164	as Latin-1. C<hash> is a precomputed hash of the key string, or zero if
	165	it has not been precomputed. Returns a mortal scalar copy of the value
	166	associated with the key, or C<&PL_sv_placeholder> if there is no value
	167	associated with the key.
	168
	169	=cut
	170	*/
	171
	172	#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \
	173	Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags)
	174
	175	/*
	176	=for apidoc Amx\|SV \|cophh_fetch_pvs\|const COPHH cophh\|const char *key\|U32 flags
	177
	178	Like L</cophh_fetch_pvn>, but takes a literal string instead of a
	179	string/length pair, and no precomputed hash.
	180
	181	=cut
	182	*/
	183
	184	#define cophh_fetch_pvs(cophh, key, flags) \
	185	Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags)
	186
	187	/*
	188	=for apidoc Amx\|SV \|cophh_fetch_pv\|const COPHH cophh\|const char *key\|U32 hash\|U32 flags
	189
	190	Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of
	191	a string/length pair.
	192
	193	=cut
	194	*/
	195
	196	#define cophh_fetch_pv(cophh, key, hash, flags) \
	197	Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags)
	198
	199	/*
	200	=for apidoc Amx\|SV \|cophh_fetch_sv\|const COPHH cophh\|SV *key\|U32 hash\|U32 flags
	201
	202	Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a
	203	string/length pair.
	204
	205	=cut
	206	*/
	207
	208	#define cophh_fetch_sv(cophh, key, hash, flags) \
	209	Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags)
	210
	211	/*
	212	=for apidoc Amx\|HV \|cophh_2hv\|const COPHH cophh\|U32 flags
	213
	214	Generates and returns a standard Perl hash representing the full set of
	215	key/value pairs in the cop hints hash C<cophh>. C<flags> is currently
	216	unused and must be zero.
	217
	218	=cut
	219	*/
	220
	221	#define cophh_2hv(cophh, flags) \
	222	Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags)
	223
	224	/*
	225	=for apidoc Amx\|COPHH \|cophh_copy\|COPHH cophh
	226
	227	Make and return a complete copy of the cop hints hash C<cophh>.
	228
	229	=cut
	230	*/
	231
	232	#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh)
	233
	234	/*
	235	=for apidoc Amx\|void\|cophh_free\|COPHH *cophh
	236
	237	Discard the cop hints hash C<cophh>, freeing all resources associated
	238	with it.
	239
	240	=cut
	241	*/
	242
	243	#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh)
	244
	245	/*
	246	=for apidoc Amx\|COPHH *\|cophh_new_empty
	247
	248	Generate and return a fresh cop hints hash containing no entries.
	249
	250	=cut
	251	*/
	252
	253	#define cophh_new_empty() ((COPHH *)NULL)
	254
	255	/*
	256	=for apidoc Amx\|COPHH \|cophh_store_pvn\|COPHH cophh\|const char keypv\|STRLEN keylen\|U32 hash\|SV value\|U32 flags
	257
	258	Stores a value, associated with a key, in the cop hints hash C<cophh>,
	259	and returns the modified hash. The returned hash pointer is in general
	260	not the same as the hash pointer that was passed in. The input hash is
	261	consumed by the function, and the pointer to it must not be subsequently
	262	used. Use L</cophh_copy> if you need both hashes.
	263
	264	The key is specified by C<keypv> and C<keylen>. If C<flags> has the
	265	C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
	266	otherwise they are interpreted as Latin-1. C<hash> is a precomputed
	267	hash of the key string, or zero if it has not been precomputed.
	268
	269	C<value> is the scalar value to store for this key. C<value> is copied
	270	by this function, which thus does not take ownership of any reference
	271	to it, and later changes to the scalar will not be reflected in the
	272	value visible in the cop hints hash. Complex types of scalar will not
	273	be stored with referential integrity, but will be coerced to strings.
	274
	275	=cut
	276	*/
	277
	278	#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
	279	Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags)
	280
	281	/*
	282	=for apidoc Amx\|COPHH \|cophh_store_pvs\|const COPHH cophh\|const char key\|SV value\|U32 flags
	283
	284	Like L</cophh_store_pvn>, but takes a literal string instead of a
	285	string/length pair, and no precomputed hash.
	286
	287	=cut
	288	*/
	289
	290	#define cophh_store_pvs(cophh, key, value, flags) \
	291	Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags)
	292
	293	/*
	294	=for apidoc Amx\|COPHH \|cophh_store_pv\|const COPHH cophh\|const char key\|U32 hash\|SV value\|U32 flags
	295
	296	Like L</cophh_store_pvn>, but takes a nul-terminated string instead of
	297	a string/length pair.
	298
	299	=cut
	300	*/
	301
	302	#define cophh_store_pv(cophh, key, hash, value, flags) \
	303	Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags)
	304
	305	/*
	306	=for apidoc Amx\|COPHH \|cophh_store_sv\|const COPHH cophh\|SV key\|U32 hash\|SV value\|U32 flags
	307
	308	Like L</cophh_store_pvn>, but takes a Perl scalar instead of a
	309	string/length pair.
	310
	311	=cut
	312	*/
	313
	314	#define cophh_store_sv(cophh, key, hash, value, flags) \
	315	Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags)
	316
	317	/*
	318	=for apidoc Amx\|COPHH \|cophh_delete_pvn\|COPHH cophh\|const char *keypv\|STRLEN keylen\|U32 hash\|U32 flags
	319
	320	Delete a key and its associated value from the cop hints hash C<cophh>,
	321	and returns the modified hash. The returned hash pointer is in general
	322	not the same as the hash pointer that was passed in. The input hash is
	323	consumed by the function, and the pointer to it must not be subsequently
	324	used. Use L</cophh_copy> if you need both hashes.
	325
	326	The key is specified by C<keypv> and C<keylen>. If C<flags> has the
	327	C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
	328	otherwise they are interpreted as Latin-1. C<hash> is a precomputed
	329	hash of the key string, or zero if it has not been precomputed.
	330
	331	=cut
	332	*/
	333
	334	#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \
	335	Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \
	336	(SV *)NULL, flags)
	337
	338	/*
	339	=for apidoc Amx\|COPHH \|cophh_delete_pvs\|const COPHH cophh\|const char *key\|U32 flags
	340
	341	Like L</cophh_delete_pvn>, but takes a literal string instead of a
	342	string/length pair, and no precomputed hash.
	343
	344	=cut
	345	*/
	346
	347	#define cophh_delete_pvs(cophh, key, flags) \
	348	Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \
	349	(SV *)NULL, flags)
	350
	351	/*
	352	=for apidoc Amx\|COPHH \|cophh_delete_pv\|const COPHH cophh\|const char *key\|U32 hash\|U32 flags
	353
	354	Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
	355	a string/length pair.
	356
	357	=cut
	358	*/
	359
	360	#define cophh_delete_pv(cophh, key, hash, flags) \
	361	Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
	362
	363	/*
	364	=for apidoc Amx\|COPHH \|cophh_delete_sv\|const COPHH cophh\|SV *key\|U32 hash\|U32 flags
	365
	366	Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
	367	string/length pair.
	368
	369	=cut
	370	*/
	371
	372	#define cophh_delete_sv(cophh, key, hash, flags) \
	373	Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
	374
	375	#include "mydtrace.h"
	376
	377	struct cop {
	378	BASEOP
	379	/* On LP64 putting this here takes advantage of the fact that BASEOP isn't
	380	an exact multiple of 8 bytes to save structure padding. */
	381	line_t cop_line; /* line # of this command */
	382	/* label for this construct is now stored in cop_hints_hash */
	383	#ifdef USE_ITHREADS
	384	PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the
	385	package the line was compiled in */
	386	char * cop_file; /* file name the following line # is from */
	387	#else
	388	HV * cop_stash; /* package line was compiled in */
	389	GV * cop_filegv; /* file the following line # is from */
	390	#endif
	391	U32 cop_hints; /* hints bits from pragmata */
	392	U32 cop_seq; /* parse sequence number */
	393	/* Beware. mg.c and warnings.pl assume the type of this is STRLEN : /
	394	STRLEN * cop_warnings; /* lexical warnings bitmask */
	395	/* compile time state of %^H. See the comment in op.c for how this is
	396	used to recreate a hash to return from caller. */
	397	COPHH * cop_hints_hash;
	398	};
	399
	400	#ifdef USE_ITHREADS
	401	# define CopFILE(c) ((c)->cop_file)
	402	# define CopFILEGV(c) (CopFILE(c) \
	403	? gv_fetchfile(CopFILE(c)) : NULL)
	404
	405	# ifdef NETWARE
	406	# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
	407	# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepvn((pv),(l)))
	408	# else
	409	# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
	410	# define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l)))
	411	# endif
	412
	413	# define CopFILESV(c) (CopFILE(c) \
	414	? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
	415	# define CopFILEAV(c) (CopFILE(c) \
	416	? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
	417	# define CopFILEAVx(c) (assert_(CopFILE(c)) \
	418	GvAV(gv_fetchfile(CopFILE(c))))
	419
	420	# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff]
	421	# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \
	422	? alloccopstash(hv) \
	423	: 0)
	424	# ifdef NETWARE
	425	# define CopFILE_free(c) SAVECOPFILE_FREE(c)
	426	# else
	427	# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
	428	# endif
	429	#else
	430	# define CopFILEGV(c) ((c)->cop_filegv)
	431	# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
	432	# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
	433	# define CopFILE_setn(c,pv,l) CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
	434	# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
	435	# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
	436	# ifdef DEBUGGING
	437	# define CopFILEAVx(c) (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
	438	# else
	439	# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
	440	# endif
	441	# define CopFILE(c) (CopFILEGV(c) \
	442	? GvNAME(CopFILEGV(c))+2 : NULL)
	443	# define CopSTASH(c) ((c)->cop_stash)
	444	# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
	445	# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
	446
	447	#endif /* USE_ITHREADS */
	448
	449	#define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
	450	/* cop_stash is not refcounted */
	451	#define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
	452	#define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
	453
	454	#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
	455	#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h))
	456
	457	/*
	458	=head1 COP Hint Reading
	459	*/
	460
	461	/*
	462	=for apidoc Am\|SV \|cop_hints_fetch_pvn\|const COP cop\|const char *keypv\|STRLEN keylen\|U32 hash\|U32 flags
	463
	464	Look up the hint entry in the cop C<cop> with the key specified by
	465	C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
	466	the key octets are interpreted as UTF-8, otherwise they are interpreted
	467	as Latin-1. C<hash> is a precomputed hash of the key string, or zero if
	468	it has not been precomputed. Returns a mortal scalar copy of the value
	469	associated with the key, or C<&PL_sv_placeholder> if there is no value
	470	associated with the key.
	471
	472	=cut
	473	*/
	474
	475	#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \
	476	cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
	477
	478	/*
	479	=for apidoc Am\|SV \|cop_hints_fetch_pvs\|const COP cop\|const char *key\|U32 flags
	480
	481	Like L</cop_hints_fetch_pvn>, but takes a literal string instead of a
	482	string/length pair, and no precomputed hash.
	483
	484	=cut
	485	*/
	486
	487	#define cop_hints_fetch_pvs(cop, key, flags) \
	488	cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags)
	489
	490	/*
	491	=for apidoc Am\|SV \|cop_hints_fetch_pv\|const COP cop\|const char *key\|U32 hash\|U32 flags
	492
	493	Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead
	494	of a string/length pair.
	495
	496	=cut
	497	*/
	498
	499	#define cop_hints_fetch_pv(cop, key, hash, flags) \
	500	cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags)
	501
	502	/*
	503	=for apidoc Am\|SV \|cop_hints_fetch_sv\|const COP cop\|SV *key\|U32 hash\|U32 flags
	504
	505	Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a
	506	string/length pair.
	507
	508	=cut
	509	*/
	510
	511	#define cop_hints_fetch_sv(cop, key, hash, flags) \
	512	cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags)
	513
	514	/*
	515	=for apidoc Am\|HV \|cop_hints_2hv\|const COP cop\|U32 flags
	516
	517	Generates and returns a standard Perl hash representing the full set of
	518	hint entries in the cop C<cop>. C<flags> is currently unused and must
	519	be zero.
	520
	521	=cut
	522	*/
	523
	524	#define cop_hints_2hv(cop, flags) \
	525	cophh_2hv(CopHINTHASH_get(cop), flags)
	526
	527	#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
	528	#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
	529	#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
	530	#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
	531
	532	#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
	533	#define CopLINE(c) ((c)->cop_line)
	534	#define CopLINE_inc(c) (++CopLINE(c))
	535	#define CopLINE_dec(c) (--CopLINE(c))
	536	#define CopLINE_set(c,l) (CopLINE(c) = (l))
	537
	538	/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
	539	#define OutCopFILE(c) CopFILE(c)
	540
	541	#define CopHINTS_get(c) ((c)->cop_hints + 0)
	542	#define CopHINTS_set(c, h) STMT_START { \
	543	(c)->cop_hints = (h); \
	544	} STMT_END
	545
	546	/*
	547	* Here we have some enormously heavy (or at least ponderous) wizardry.
	548	*/
	549
	550	/* subroutine context */
	551	struct block_sub {
	552	OP * retop; /* op to execute on exit from sub */
	553	/* Above here is the same for sub, format and eval. */
	554	PAD prevcomppad; / the caller's PL_comppad */
	555	CV * cv;
	556	/* Above here is the same for sub and format. */
	557	I32 olddepth;
	558	AV *savearray;
	559	};
	560
	561
	562	/* format context */
	563	struct block_format {
	564	OP * retop; /* op to execute on exit from sub */
	565	/* Above here is the same for sub, format and eval. */
	566	PAD prevcomppad; / the caller's PL_comppad */
	567	CV * cv;
	568	/* Above here is the same for sub and format. */
	569	GV * gv;
	570	GV * dfoutgv;
	571	};
	572
	573	/* free all savestack items back to the watermark of the specified context */
	574
	575	#define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->cx_old_savestack_ix)
	576
	577	/* base for the next two macros. Don't use directly.
	578	* The context frame holds a reference to the CV so that it can't be
	579	* freed while we're executing it */
	580
	581	#define PUSHSUB_BASE(cx) \
	582	ENTRY_PROBE(CvNAMED(cv) \
	583	? HEK_KEY(CvNAME_HEK(cv)) \
	584	: GvENAME(CvGV(cv)), \
	585	CopFILE((const COP *)CvSTART(cv)), \
	586	CopLINE((const COP *)CvSTART(cv)), \
	587	CopSTASHPV((const COP *)CvSTART(cv))); \
	588	\
	589	cx->blk_sub.cv = cv; \
	590	cx->blk_sub.olddepth = CvDEPTH(cv); \
	591	cx->blk_sub.prevcomppad = PL_comppad; \
	592	cx->cx_type \|= (hasargs) ? CXp_HASARGS : 0; \
	593	cx->blk_sub.retop = NULL; \
	594	SvREFCNT_inc_simple_void_NN(cv);
	595
	596	#define PUSHSUB_GET_LVALUE_MASK(func) \
	597	/* If the context is indeterminate, then only the lvalue */ \
	598	/* flags that the caller also has are applicable. */ \
	599	( \
	600	(PL_op->op_flags & OPf_WANT) \
	601	? OPpENTERSUB_LVAL_MASK \
	602	: !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \
	603	? 0 : (U8)func(aTHX) \
	604	)
	605
	606	#define PUSHSUB(cx) \
	607	{ \
	608	U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \
	609	PUSHSUB_BASE(cx) \
	610	cx->blk_u16 = PL_op->op_private & \
	611	(phlags\|OPpDEREF); \
	612	}
	613
	614	/* variant for use by OP_DBSTATE, where op_private holds hint bits */
	615	#define PUSHSUB_DB(cx) \
	616	PUSHSUB_BASE(cx) \
	617	cx->blk_u16 = 0;
	618
	619
	620	#define PUSHFORMAT(cx, retop) \
	621	cx->blk_format.cv = cv; \
	622	cx->blk_format.gv = gv; \
	623	cx->blk_format.retop = (retop); \
	624	cx->blk_format.dfoutgv = PL_defoutgv; \
	625	cx->blk_format.prevcomppad = PL_comppad; \
	626	cx->blk_u16 = 0; \
	627	cx->cx_old_savestack_ix = PL_savestack_ix; \
	628	SvREFCNT_inc_simple_void_NN(cv); \
	629	CvDEPTH(cv)++; \
	630	SvREFCNT_inc_void(cx->blk_format.dfoutgv)
	631
	632	/* Restore old @_ */
	633	#define POP_SAVEARRAY() \
	634	STMT_START { \
	635	AV *av = GvAV(PL_defgv); \
	636	GvAV(PL_defgv) = cx->blk_sub.savearray; \
	637	SvREFCNT_dec(av); \
	638	} STMT_END
	639
	640	/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
	641	* leave any (a fast av_clear(ary), basically) */
	642	#define CLEAR_ARGARRAY(ary) \
	643	STMT_START { \
	644	AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \
	645	AvARRAY(ary) = AvALLOC(ary); \
	646	AvFILLp(ary) = -1; \
	647	} STMT_END
	648
	649
	650	/* subsets of POPSUB */
	651
	652	#define POPSUB_COMMON(cx) \
	653	PL_comppad = cx->blk_sub.prevcomppad; \
	654	PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \
	655	CvDEPTH((const CV*)cx->blk_sub.cv) = cx->blk_sub.olddepth; \
	656	SvREFCNT_dec_NN(cx->blk_sub.cv);
	657
	658	/* handle the @_ part of leaving a sub */
	659
	660	#define POPSUB_ARGS(cx) \
	661	STMT_START { \
	662	AV *av; \
	663	assert(AvARRAY(MUTABLE_AV( \
	664	PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ \
	665	CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); \
	666	POP_SAVEARRAY(); \
	667	/* abandon @_ if it got reified */ \
	668	av = MUTABLE_AV(PAD_SVl(0)); \
	669	if (UNLIKELY(AvREAL(av))) \
	670	clear_defarray(av, 0); \
	671	else { \
	672	CLEAR_ARGARRAY(av); \
	673	} \
	674	} STMT_END
	675
	676	#define POPSUB(cx) \
	677	STMT_START { \
	678	if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
	679	cx->blk_u16 \|= CxPOPSUB_DONE; \
	680	RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \
	681	? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \
	682	: GvENAME(CvGV(cx->blk_sub.cv)), \
	683	CopFILE((COP)CvSTART((const CV)cx->blk_sub.cv)), \
	684	CopLINE((COP)CvSTART((const CV)cx->blk_sub.cv)), \
	685	CopSTASHPV((COP)CvSTART((const CV)cx->blk_sub.cv))); \
	686	\
	687	if (CxHASARGS(cx)) { \
	688	POPSUB_ARGS(cx); \
	689	} \
	690	} \
	691	POPSUB_COMMON(cx); \
	692	} STMT_END
	693
	694	#define POPFORMAT(cx) \
	695	STMT_START { \
	696	if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
	697	CV * const cv = cx->blk_format.cv; \
	698	GV * const dfuot = cx->blk_format.dfoutgv; \
	699	cx->blk_u16 \|= CxPOPSUB_DONE; \
	700	setdefout(dfuot); \
	701	PL_comppad = cx->blk_format.prevcomppad; \
	702	PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \
	703	--CvDEPTH(cv); \
	704	SvREFCNT_dec_NN(cx->blk_format.cv); \
	705	SvREFCNT_dec_NN(dfuot); \
	706	} \
	707	} STMT_END
	708
	709	/* eval context */
	710	struct block_eval {
	711	OP * retop; /* op to execute on exit from eval */
	712	/* Above here is the same for sub, format and eval. */
	713	SV * old_namesv;
	714	OP * old_eval_root;
	715	SV * cur_text;
	716	CV * cv;
	717	JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */
	718	};
	719
	720	/* If we ever need more than 512 op types, change the shift from 7.
	721	blku_gimme is actually also only 2 bits, so could be merged with something.
	722	*/
	723
	724	#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x7F)
	725	#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7)
	726
	727	#define PUSHEVAL(cx,n) \
	728	STMT_START { \
	729	assert(!(PL_in_eval & ~0x7F)); \
	730	assert(!(PL_op->op_type & ~0x1FF)); \
	731	cx->blk_u16 = (PL_in_eval & 0x7F) \| ((U16)PL_op->op_type << 7); \
	732	cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL); \
	733	cx->blk_eval.old_eval_root = PL_eval_root; \
	734	cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL; \
	735	cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */ \
	736	cx->blk_eval.retop = NULL; \
	737	cx->blk_eval.cur_top_env = PL_top_env; \
	738	} STMT_END
	739
	740	#define POPEVAL(cx) \
	741	STMT_START { \
	742	PL_in_eval = CxOLD_IN_EVAL(cx); \
	743	optype = CxOLD_OP_TYPE(cx); \
	744	PL_eval_root = cx->blk_eval.old_eval_root; \
	745	if (cx->blk_eval.cur_text && SvSCREAM(cx->blk_eval.cur_text)) \
	746	SvREFCNT_dec_NN(cx->blk_eval.cur_text); \
	747	if (cx->blk_eval.old_namesv) \
	748	sv_2mortal(cx->blk_eval.old_namesv); \
	749	} STMT_END
	750
	751	/* loop context */
	752	struct block_loop {
	753	I32 resetsp;
	754	LOOP * my_op; /* My op, that contains redo, next and last ops. */
	755	union { /* different ways of locating the iteration variable */
	756	SV *svp; / for lexicals: address of pad slot */
	757	GV gv; / for package vars */
	758	} itervar_u;
	759	SV itersave; / the original iteration var */
	760	union {
	761	struct { /* valid if type is LOOP_FOR or LOOP_PLAIN (but {NULL,0})*/
	762	AV * ary; /* use the stack if this is NULL */
	763	IV ix;
	764	} ary;
	765	struct { /* valid if type is LOOP_LAZYIV */
	766	IV cur;
	767	IV end;
	768	} lazyiv;
	769	struct { /* valid if type if LOOP_LAZYSV */
	770	SV * cur;
	771	SV * end; /* maxiumum value (or minimum in reverse) */
	772	} lazysv;
	773	} state_u;
	774	#ifdef USE_ITHREADS
	775	PAD oldcomppad; / needed to map itervar_u.svp during thread clone */
	776	#endif
	777	};
	778
	779	#define CxITERVAR(c) \
	780	(CxPADLOOP(c) \
	781	? (c)->blk_loop.itervar_u.svp \
	782	: ((c)->cx_type & CXp_FOR_GV) \
	783	? &GvSV((c)->blk_loop.itervar_u.gv) \
	784	: (SV **)&(c)->blk_loop.itervar_u.gv)
	785
	786	#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
	787	#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
	788	#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
	789	#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
	790	#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
	791	/* POPSUB has already been performed on this context frame */
	792	#define CxPOPSUB_DONE 0x100
	793
	794
	795	#define PUSHLOOP_PLAIN(cx, s) \
	796	cx->blk_loop.resetsp = s - PL_stack_base; \
	797	cx->blk_loop.my_op = cLOOP; \
	798	cx->blk_loop.state_u.ary.ary = NULL; \
	799	cx->blk_loop.state_u.ary.ix = 0; \
	800	cx->cx_old_savestack_ix = PL_savestack_ix; \
	801	cx->blk_loop.itervar_u.svp = NULL; \
	802	cx->blk_loop.itersave = NULL;
	803
	804	#ifdef USE_ITHREADS
	805	# define PUSHLOOP_FOR_setpad(c) (c)->blk_loop.oldcomppad = PL_comppad
	806	#else
	807	# define PUSHLOOP_FOR_setpad(c) NOOP
	808	#endif
	809
	810	#define PUSHLOOP_FOR(cx, ivar, isave, s) \
	811	cx->blk_loop.resetsp = s - PL_stack_base; \
	812	cx->blk_loop.my_op = cLOOP; \
	813	cx->blk_loop.state_u.ary.ary = NULL; \
	814	cx->blk_loop.state_u.ary.ix = 0; \
	815	cx->blk_loop.itervar_u.svp = (SV**)(ivar); \
	816	cx->cx_old_savestack_ix = PL_savestack_ix; \
	817	cx->blk_loop.itersave = isave; \
	818	PUSHLOOP_FOR_setpad(cx);
	819
	820	#define POPLOOP(cx) \
	821	if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
	822	SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.cur); \
	823	SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.end); \
	824	} \
	825	else if (CxTYPE(cx) == CXt_LOOP_FOR) \
	826	SvREFCNT_dec(cx->blk_loop.state_u.ary.ary); \
	827	if (cx->cx_type & (CXp_FOR_PAD\|CXp_FOR_GV)) { \
	828	SV *cursv; \
	829	SV **svp = (cx)->blk_loop.itervar_u.svp; \
	830	if ((cx->cx_type & CXp_FOR_GV)) \
	831	svp = &GvSV((GV*)svp); \
	832	cursv = *svp; \
	833	*svp = cx->blk_loop.itersave; \
	834	SvREFCNT_dec(cursv); \
	835	}
	836
	837	/* given/when context */
	838	struct block_givwhen {
	839	OP *leave_op;
	840	SV defsv_save; / the original $_ */
	841	};
	842
	843	#define PUSHWHEN(cx) \
	844	cx->cx_old_savestack_ix = PL_savestack_ix; \
	845	cx->blk_givwhen.leave_op = cLOGOP->op_other;
	846
	847	#define PUSHGIVEN(cx, orig_var) \
	848	PUSHWHEN(cx); \
	849	cx->blk_givwhen.defsv_save = orig_var;
	850
	851	#define POPWHEN(cx) \
	852	NOOP;
	853
	854	#define POPGIVEN(cx) \
	855	SvREFCNT_dec(GvSV(PL_defgv)); \
	856	GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
	857
	858
	859	/* basic block, i.e. pp_enter/leave */
	860
	861	#define PUSHBASICBLK(cx) \
	862	cx->cx_old_savestack_ix = PL_savestack_ix;
	863
	864	#define POPBASICBLK(cx) \
	865	NOOP;
	866
	867
	868	/* context common to subroutines, evals and loops */
	869	struct block {
	870	U8 blku_type; /* what kind of context this is */
	871	U8 blku_gimme; /* is this block running in list context? */
	872	U16 blku_u16; /* used by block_sub and block_eval (so far) */
	873	I32 blku_oldsp; /* stack pointer to copy stuff down to */
	874	COP * blku_oldcop; /* old curcop pointer */
	875	I32 blku_oldmarksp; /* mark stack index */
	876	I32 blku_oldscopesp; /* scope stack index */
	877	PMOP * blku_oldpm; /* values of pattern match vars */
	878	SSize_t blku_old_tmpsfloor; /* saved PL_tmps_floor */
	879
	880	union {
	881	struct block_sub blku_sub;
	882	struct block_format blku_format;
	883	struct block_eval blku_eval;
	884	struct block_loop blku_loop;
	885	struct block_givwhen blku_givwhen;
	886	} blk_u;
	887	};
	888	#define blk_oldsp cx_u.cx_blk.blku_oldsp
	889	#define blk_oldcop cx_u.cx_blk.blku_oldcop
	890	#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
	891	#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
	892	#define blk_oldpm cx_u.cx_blk.blku_oldpm
	893	#define blk_gimme cx_u.cx_blk.blku_gimme
	894	#define blk_u16 cx_u.cx_blk.blku_u16
	895	#define blk_sub cx_u.cx_blk.blk_u.blku_sub
	896	#define blk_format cx_u.cx_blk.blk_u.blku_format
	897	#define blk_eval cx_u.cx_blk.blk_u.blku_eval
	898	#define blk_loop cx_u.cx_blk.blk_u.blku_loop
	899	#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
	900
	901	#define DEBUG_CX(action) \
	902	DEBUG_l( \
	903	Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\
	904	(long)cxstack_ix, \
	905	action, \
	906	PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
	907	(long)PL_scopestack_ix, \
	908	(long)(cxstack[cxstack_ix].blk_oldscopesp), \
	909	(long)PL_savestack_ix, \
	910	(long)(cxstack[cxstack_ix].cx_old_savestack_ix), \
	911	__FILE__, __LINE__));
	912
	913	/* Enter a block. */
	914	#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
	915	cx->cx_type = t, \
	916	cx->blk_oldsp = sp - PL_stack_base, \
	917	cx->blk_oldcop = PL_curcop, \
	918	cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
	919	cx->blk_oldscopesp = PL_scopestack_ix, \
	920	cx->blk_oldpm = PL_curpm, \
	921	cx->blk_gimme = (U8)gimme; \
	922	cx->cx_u.cx_blk.blku_old_tmpsfloor = PL_tmps_floor; \
	923	PL_tmps_floor = PL_tmps_ix; \
	924	DEBUG_CX("PUSH");
	925
	926	/* Exit a block (RETURN and LAST). */
	927	#define POPBLOCK(cx) \
	928	DEBUG_CX("POP"); \
	929	PL_curcop = cx->blk_oldcop, \
	930	PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
	931	PL_scopestack_ix = cx->blk_oldscopesp, \
	932	/* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
	933	* and leaves a CX entry lying around for repeated use, so
	934	* skip for multicall */ \
	935	assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx)) \
	936	\|\| PL_savestack_ix == cx->cx_old_savestack_ix); \
	937	PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor; \
	938	PL_curpm = cx->blk_oldpm;
	939
	940	/* Continue a block elsewhere (NEXT and REDO). */
	941	#define TOPBLOCK(cx) \
	942	DEBUG_CX("TOP"); \
	943	cx = &cxstack[cxstack_ix], \
	944	PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
	945	PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
	946	PL_scopestack_ix = cx->blk_oldscopesp, \
	947	PL_curpm = cx->blk_oldpm;
	948
	949	/* substitution context */
	950	struct subst {
	951	U8 sbu_type; /* what kind of context this is */
	952	U8 sbu_rflags;
	953	U16 sbu_rxtainted; /* matches struct block */
	954	SSize_t sbu_iters;
	955	SSize_t sbu_maxiters;
	956	char * sbu_orig;
	957	SV * sbu_dstr;
	958	SV * sbu_targ;
	959	char * sbu_s;
	960	char * sbu_m;
	961	char * sbu_strend;
	962	void * sbu_rxres;
	963	REGEXP * sbu_rx;
	964	};
	965	#define sb_iters cx_u.cx_subst.sbu_iters
	966	#define sb_maxiters cx_u.cx_subst.sbu_maxiters
	967	#define sb_rflags cx_u.cx_subst.sbu_rflags
	968	#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
	969	#define sb_orig cx_u.cx_subst.sbu_orig
	970	#define sb_dstr cx_u.cx_subst.sbu_dstr
	971	#define sb_targ cx_u.cx_subst.sbu_targ
	972	#define sb_s cx_u.cx_subst.sbu_s
	973	#define sb_m cx_u.cx_subst.sbu_m
	974	#define sb_strend cx_u.cx_subst.sbu_strend
	975	#define sb_rxres cx_u.cx_subst.sbu_rxres
	976	#define sb_rx cx_u.cx_subst.sbu_rx
	977
	978	#ifdef PERL_CORE
	979	# define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
	980	cx->cx_old_savestack_ix = oldsave, \
	981	cx->sb_iters = iters, \
	982	cx->sb_maxiters = maxiters, \
	983	cx->sb_rflags = r_flags, \
	984	cx->sb_rxtainted = rxtainted, \
	985	cx->sb_orig = orig, \
	986	cx->sb_dstr = dstr, \
	987	cx->sb_targ = targ, \
	988	cx->sb_s = s, \
	989	cx->sb_m = m, \
	990	cx->sb_strend = strend, \
	991	cx->sb_rxres = NULL, \
	992	cx->sb_rx = rx, \
	993	cx->cx_type = CXt_SUBST \| (once ? CXp_ONCE : 0); \
	994	rxres_save(&cx->sb_rxres, rx); \
	995	(void)ReREFCNT_inc(rx); \
	996	SvREFCNT_inc_void_NN(targ)
	997
	998	# define POPSUBST(cx) \
	999	rxres_free(&cx->sb_rxres); \
	1000	ReREFCNT_dec(cx->sb_rx); \
	1001	SvREFCNT_dec_NN(cx->sb_targ)
	1002	#endif
	1003
	1004	#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
	1005
	1006	struct context {
	1007	I32 cx_old_savestack_ix; /* saved PL_savestack_ix */
	1008	union {
	1009	struct block cx_blk;
	1010	struct subst cx_subst;
	1011	} cx_u;
	1012	};
	1013	#define cx_type cx_u.cx_subst.sbu_type
	1014
	1015	/* If you re-order these, there is also an array of uppercase names in perl.h
	1016	and a static array of context names in pp_ctl.c */
	1017	#define CXTYPEMASK 0xf
	1018	#define CXt_NULL 0 /* currently only used for sort BLOCK */
	1019	#define CXt_WHEN 1
	1020	#define CXt_BLOCK 2
	1021	/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
	1022	jump table in pp_ctl.c
	1023	The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
	1024	*/
	1025	#define CXt_GIVEN 3
	1026	/* This is first so that CXt_LOOP_FOR\|CXt_LOOP_LAZYIV is CXt_LOOP_LAZYIV */
	1027	#define CXt_LOOP_FOR 4
	1028	#define CXt_LOOP_PLAIN 5
	1029	#define CXt_LOOP_LAZYSV 6
	1030	#define CXt_LOOP_LAZYIV 7
	1031	#define CXt_SUB 8
	1032	#define CXt_FORMAT 9
	1033	#define CXt_EVAL 10
	1034	#define CXt_SUBST 11
	1035	/* SUBST doesn't feature in all switch statements. */
	1036
	1037	/* private flags for CXt_SUB and CXt_FORMAT */
	1038	#define CXp_MULTICALL 0x10 /* part of a multicall (so don't tear down
	1039	context on exit). (not CXt_FORMAT) */
	1040	#define CXp_HASARGS 0x20
	1041	#define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */
	1042	#define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */
	1043
	1044	/* private flags for CXt_EVAL */
	1045	#define CXp_REAL 0x20 /* truly eval'', not a lookalike */
	1046	#define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */
	1047
	1048	/* private flags for CXt_LOOP */
	1049	#define CXp_FOR_DEF 0x10 /* foreach using $_ */
	1050	#define CXp_FOR_LVREF 0x20 /* foreach using \$var */
	1051	#define CXp_FOR_GV 0x40 /* foreach using package var */
	1052	#define CXp_FOR_PAD 0x80 /* foreach using lexical var */
	1053	#define CxPADLOOP(c) ((c)->cx_type & CXp_FOR_PAD)
	1054
	1055	/* private flags for CXt_SUBST */
	1056	#define CXp_ONCE 0x10 /* What was sbu_once in struct subst */
	1057
	1058	#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
	1059	#define CxTYPE_is_LOOP(c) (((c)->cx_type & 0xC) == 0x4)
	1060	#define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL)
	1061	#define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK\|CXp_REAL)) \
	1062	== (CXt_EVAL\|CXp_REAL))
	1063	#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK\|CXp_TRYBLOCK)) \
	1064	== (CXt_EVAL\|CXp_TRYBLOCK))
	1065	#define CxFOREACH(c) (CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN)
	1066	#define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \
	1067	&& ((c)->cx_type & CXp_FOR_DEF))
	1068
	1069	#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
	1070
	1071	/*
	1072	=head1 "Gimme" Values
	1073	*/
	1074
	1075	/*
	1076	=for apidoc AmU\|\|G_SCALAR
	1077	Used to indicate scalar context. See C<L</GIMME_V>>, C<L</GIMME>>, and
	1078	L<perlcall>.
	1079
	1080	=for apidoc AmU\|\|G_ARRAY
	1081	Used to indicate list context. See C<L</GIMME_V>>, C<L</GIMME>> and
	1082	L<perlcall>.
	1083
	1084	=for apidoc AmU\|\|G_VOID
	1085	Used to indicate void context. See C<L</GIMME_V>> and L<perlcall>.
	1086
	1087	=for apidoc AmU\|\|G_DISCARD
	1088	Indicates that arguments returned from a callback should be discarded. See
	1089	L<perlcall>.
	1090
	1091	=for apidoc AmU\|\|G_EVAL
	1092
	1093	Used to force a Perl C<eval> wrapper around a callback. See
	1094	L<perlcall>.
	1095
	1096	=for apidoc AmU\|\|G_NOARGS
	1097
	1098	Indicates that no arguments are being sent to a callback. See
	1099	L<perlcall>.
	1100
	1101	=cut
	1102	*/
	1103
	1104	#define G_SCALAR 2
	1105	#define G_ARRAY 3
	1106	#define G_VOID 1
	1107	#define G_WANT 3
	1108
	1109	/* extra flags for Perl_call_* routines */
	1110	#define G_DISCARD 4 /* Call FREETMPS.
	1111	Don't change this without consulting the
	1112	hash actions codes defined in hv.h */
	1113	#define G_EVAL 8 /* Assume eval {} around subroutine call. */
	1114	#define G_NOARGS 16 /* Don't construct a @_ array. */
	1115	#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
	1116	#define G_NODEBUG 64 /* Disable debugging at toplevel. */
	1117	#define G_METHOD 128 /* Calling method. */
	1118	#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
	1119	fold_constants. */
	1120	#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
	1121	A special case for UNSHIFT in
	1122	Perl_magic_methcall(). */
	1123	#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
	1124	Perl_magic_methcall(). */
	1125	#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
	1126	#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
	1127
	1128	/* flag bits for PL_in_eval */
	1129	#define EVAL_NULL 0 /* not in an eval */
	1130	#define EVAL_INEVAL 1 /* some enclosing scope is an eval */
	1131	#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
	1132	#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
	1133	#define EVAL_INREQUIRE 8 /* The code is being required. */
	1134	#define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */
	1135
	1136	/* Support for switching (stack and block) contexts.
	1137	* This ensures magic doesn't invalidate local stack and cx pointers.
	1138	*/
	1139
	1140	#define PERLSI_UNKNOWN -1
	1141	#define PERLSI_UNDEF 0
	1142	#define PERLSI_MAIN 1
	1143	#define PERLSI_MAGIC 2
	1144	#define PERLSI_SORT 3
	1145	#define PERLSI_SIGNAL 4
	1146	#define PERLSI_OVERLOAD 5
	1147	#define PERLSI_DESTROY 6
	1148	#define PERLSI_WARNHOOK 7
	1149	#define PERLSI_DIEHOOK 8
	1150	#define PERLSI_REQUIRE 9
	1151	#define PERLSI_MULTICALL 10
	1152
	1153	struct stackinfo {
	1154	AV * si_stack; /* stack for current runlevel */
	1155	PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
	1156	struct stackinfo * si_prev;
	1157	struct stackinfo * si_next;
	1158	I32 si_cxix; /* current context index */
	1159	I32 si_cxmax; /* maximum allocated index */
	1160	I32 si_type; /* type of runlevel */
	1161	I32 si_markoff; /* offset where markstack begins for us.
	1162	* currently used only with DEBUGGING,
	1163	* but not #ifdef-ed for bincompat */
	1164	};
	1165
	1166	typedef struct stackinfo PERL_SI;
	1167
	1168	#define cxstack (PL_curstackinfo->si_cxstack)
	1169	#define cxstack_ix (PL_curstackinfo->si_cxix)
	1170	#define cxstack_max (PL_curstackinfo->si_cxmax)
	1171
	1172	#ifdef DEBUGGING
	1173	# define SET_MARK_OFFSET \
	1174	PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
	1175	#else
	1176	# define SET_MARK_OFFSET NOOP
	1177	#endif
	1178
	1179	#define PUSHSTACKi(type) \
	1180	STMT_START { \
	1181	PERL_SI *next = PL_curstackinfo->si_next; \
	1182	DEBUG_l({ \
	1183	int i = 0; PERL_SI *p = PL_curstackinfo; \
	1184	while (p) { i++; p = p->si_prev; } \
	1185	Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
	1186	i, __FILE__, __LINE__);}) \
	1187	if (!next) { \
	1188	next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
	1189	next->si_prev = PL_curstackinfo; \
	1190	PL_curstackinfo->si_next = next; \
	1191	} \
	1192	next->si_type = type; \
	1193	next->si_cxix = -1; \
	1194	AvFILLp(next->si_stack) = 0; \
	1195	SWITCHSTACK(PL_curstack,next->si_stack); \
	1196	PL_curstackinfo = next; \
	1197	SET_MARK_OFFSET; \
	1198	} STMT_END
	1199
	1200	#define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
	1201
	1202	/* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
	1203	* PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
	1204	#define POPSTACK \
	1205	STMT_START { \
	1206	dSP; \
	1207	PERL_SI * const prev = PL_curstackinfo->si_prev; \
	1208	DEBUG_l({ \
	1209	int i = -1; PERL_SI *p = PL_curstackinfo; \
	1210	while (p) { i++; p = p->si_prev; } \
	1211	Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
	1212	i, __FILE__, __LINE__);}) \
	1213	if (!prev) { \
	1214	Perl_croak_popstack(); \
	1215	} \
	1216	SWITCHSTACK(PL_curstack,prev->si_stack); \
	1217	/* don't free prev here, free them all at the END{} */ \
	1218	PL_curstackinfo = prev; \
	1219	} STMT_END
	1220
	1221	#define POPSTACK_TO(s) \
	1222	STMT_START { \
	1223	while (PL_curstack != s) { \
	1224	dounwind(-1); \
	1225	POPSTACK; \
	1226	} \
	1227	} STMT_END
	1228
	1229	#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
	1230	#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
	1231
	1232	/*
	1233	=head1 Multicall Functions
	1234
	1235	=for apidoc Ams\|\|dMULTICALL
	1236	Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
	1237
	1238	=for apidoc Ams\|\|PUSH_MULTICALL
	1239	Opening bracket for a lightweight callback.
	1240	See L<perlcall/LIGHTWEIGHT CALLBACKS>.
	1241
	1242	=for apidoc Ams\|\|MULTICALL
	1243	Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
	1244
	1245	=for apidoc Ams\|\|POP_MULTICALL
	1246	Closing bracket for a lightweight callback.
	1247	See L<perlcall/LIGHTWEIGHT CALLBACKS>.
	1248
	1249	=cut
	1250	*/
	1251
	1252	#define dMULTICALL \
	1253	SV *newsp; / set by POPBLOCK */ \
	1254	PERL_CONTEXT *cx; \
	1255	CV *multicall_cv; \
	1256	OP *multicall_cop; \
	1257	bool multicall_oldcatch; \
	1258	U8 hasargs = 0 /* used by PUSHSUB */
	1259
	1260	#define PUSH_MULTICALL(the_cv) \
	1261	PUSH_MULTICALL_FLAGS(the_cv, 0)
	1262
	1263	/* Like PUSH_MULTICALL, but allows you to specify extra flags
	1264	* for the CX stack entry (this isn't part of the public API) */
	1265
	1266	#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
	1267	STMT_START { \
	1268	CV * const _nOnclAshIngNamE_ = the_cv; \
	1269	CV * const cv = _nOnclAshIngNamE_; \
	1270	PADLIST * const padlist = CvPADLIST(cv); \
	1271	multicall_oldcatch = CATCH_GET; \
	1272	CATCH_SET(TRUE); \
	1273	PUSHSTACKi(PERLSI_MULTICALL); \
	1274	PUSHBLOCK(cx, (CXt_SUB\|CXp_MULTICALL\|flags), PL_stack_sp); \
	1275	PUSHSUB(cx); \
	1276	cx->cx_old_savestack_ix = PL_savestack_ix; \
	1277	SAVEVPTR(PL_op); \
	1278	if (!(flags & CXp_SUB_RE_FAKE)) \
	1279	CvDEPTH(cv)++; \
	1280	if (CvDEPTH(cv) >= 2) { \
	1281	PERL_STACK_OVERFLOW_CHECK(); \
	1282	Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
	1283	} \
	1284	PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
	1285	multicall_cv = cv; \
	1286	PERL_UNUSED_VAR(multicall_cv); /* for API */ \
	1287	multicall_cop = CvSTART(cv); \
	1288	} STMT_END
	1289
	1290	#define MULTICALL \
	1291	STMT_START { \
	1292	PL_op = multicall_cop; \
	1293	CALLRUNOPS(aTHX); \
	1294	} STMT_END
	1295
	1296	#define POP_MULTICALL \
	1297	STMT_START { \
	1298	cx = &cxstack[cxstack_ix]; \
	1299	CX_LEAVE_SCOPE(cx); \
	1300	POPSUB_COMMON(cx); \
	1301	POPBLOCK(cx); \
	1302	newsp = PL_stack_base + cx->blk_oldsp; \
	1303	gimme = cx->blk_gimme; \
	1304	PERL_UNUSED_VAR(newsp); /* for API */ \
	1305	PERL_UNUSED_VAR(gimme); /* for API */ \
	1306	cxstack_ix--; \
	1307	POPSTACK; \
	1308	CATCH_SET(multicall_oldcatch); \
	1309	SPAGAIN; \
	1310	} STMT_END
	1311
	1312	/* Change the CV of an already-pushed MULTICALL CxSUB block.
	1313	* (this isn't part of the public API) */
	1314
	1315	#define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
	1316	STMT_START { \
	1317	CV * const _nOnclAshIngNamE_ = the_cv; \
	1318	CV * const cv = _nOnclAshIngNamE_; \
	1319	PADLIST * const padlist = CvPADLIST(cv); \
	1320	cx = &cxstack[cxstack_ix]; \
	1321	assert(CxMULTICALL(cx)); \
	1322	CvDEPTH(multicall_cv) = cx->blk_sub.olddepth; \
	1323	SvREFCNT_dec_NN(multicall_cv); \
	1324	cx->cx_type = (CXt_SUB\|CXp_MULTICALL\|flags); \
	1325	{ \
	1326	/* save a few things that we don't want PUSHSUB to zap */ \
	1327	PAD * const prevcomppad = cx->blk_sub.prevcomppad; \
	1328	PUSHSUB(cx); \
	1329	/* undo the stuff that PUSHSUB zapped */ \
	1330	cx->blk_sub.prevcomppad = prevcomppad ; \
	1331	} \
	1332	if (!(flags & CXp_SUB_RE_FAKE)) \
	1333	CvDEPTH(cv)++; \
	1334	if (CvDEPTH(cv) >= 2) { \
	1335	PERL_STACK_OVERFLOW_CHECK(); \
	1336	Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
	1337	} \
	1338	PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
	1339	multicall_cv = cv; \
	1340	multicall_cop = CvSTART(cv); \
	1341	} STMT_END
	1342	/*
	1343	* ex: set ts=8 sts=4 sw=4 et:
	1344	*/