-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathmulticall.h
200 lines (182 loc) · 5.36 KB
/
multicall.h
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
/* from vutil.h
* Perl 5 license
*/
#ifndef PERL_VERSION_DECIMAL
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
# define PERL_DECIMAL_VERSION \
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_LT
# define PERL_VERSION_LT(r,v,s) \
(PERL_DECIMAL_VERSION < PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
# define PERL_VERSION_LE(r,v,s) \
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_GE
# define PERL_VERSION_GE(r,v,s) \
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_GT
# define PERL_VERSION_GT(r,v,s) \
(PERL_DECIMAL_VERSION > PERL_VERSION_DECIMAL(r,v,s))
#endif
/* multicall.h (version 1.0)
*
* Implements a poor-man's MULTICALL interface for old versions
* of perl that don't offer a proper one. Intended to be compatible
* with 5.6.0 and later.
*
*/
#if PERL_VERSION_GE(5,8,8) && PERL_VERSION_LT(5,10,1)
# undef dMULTICALL
# undef MULTICALL_PUSHSUB
# undef PUSH_MULTICALL
# undef POP_MULTICALL
#endif
#ifdef dMULTICALL
#define REAL_MULTICALL
#else
#undef REAL_MULTICALL
/* In versions of perl where MULTICALL is not defined (i.e. prior
* to 5.9.4), Perl_pad_push is not exported either. It also has
* an extra argument in older versions; certainly in the 5.8 series.
* So we redefine it here.
*/
#ifndef AVf_REIFY
# ifdef SVpav_REIFY
# define AVf_REIFY SVpav_REIFY
# else
# error Neither AVf_REIFY nor SVpav_REIFY is defined
# endif
#endif
#ifndef AvFLAGS
# define AvFLAGS SvFLAGS
#endif
static void
multicall_pad_push(pTHX_ AV *padlist, int depth)
{
if (depth <= AvFILLp(padlist))
return;
{
SV** const svp = AvARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((AV*)svp[1]);
const I32 names_fill = AvFILLp((AV*)svp[0]);
SV** const names = AvARRAY(svp[0]);
AV *av;
for ( ;ix > 0; ix--) {
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
const char sigil = SvPVX(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
/* outer lexical or anon code */
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else { /* our own lexical */
SV *sv;
if (sigil == '@')
sv = (SV*)newAV();
else if (sigil == '%')
sv = (SV*)newHV();
else
sv = NEWSV(0, 0);
av_store(newpad, ix, sv);
SvPADMY_on(sv);
}
}
else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else {
/* save temporaries on recursion? */
SV * const sv = NEWSV(0, 0);
av_store(newpad, ix, sv);
SvPADTMP_on(sv);
}
}
av = newAV();
av_extend(av, 0);
av_store(newpad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
av_store(padlist, depth, (SV*)newpad);
AvFILLp(padlist) = depth;
}
}
#define dMULTICALL \
SV **newsp; /* set by POPBLOCK */ \
PERL_CONTEXT *cx; \
CV *multicall_cv; \
OP *multicall_cop; \
bool multicall_oldcatch; \
U8 hasargs = 0
/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
return op is now stored on the cxstack. */
#define HAS_RETSTACK (\
PERL_REVISION < 5 || \
(PERL_REVISION == 5 && PERL_VERSION < 9) || \
(PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
)
/* PUSHSUB is defined so differently on different versions of perl
* that it's easier to define our own version than code for all the
* different possibilities.
*/
#if HAS_RETSTACK
# define PUSHSUB_RETSTACK(cx)
#else
# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
#endif
#define MULTICALL_PUSHSUB(cx, the_cv) \
cx->blk_sub.cv = the_cv; \
cx->blk_sub.olddepth = CvDEPTH(the_cv); \
cx->blk_sub.hasargs = hasargs; \
cx->blk_sub.lval = PL_op->op_private & \
(OPpLVAL_INTRO|OPpENTERSUB_INARGS); \
PUSHSUB_RETSTACK(cx) \
if (!CvDEPTH(the_cv)) { \
(void)SvREFCNT_inc(the_cv); \
(void)SvREFCNT_inc(the_cv); \
SAVEFREESV(the_cv); \
}
#define PUSH_MULTICALL(the_cv) \
STMT_START { \
CV *_nOnclAshIngNamE_ = the_cv; \
AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
multicall_cv = _nOnclAshIngNamE_; \
ENTER; \
multicall_oldcatch = CATCH_GET; \
SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \
CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
SAVETMPS; SAVEVPTR(PL_op); \
CATCH_SET(TRUE); \
PUSHSTACKi(PERLSI_SORT); \
PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \
MULTICALL_PUSHSUB(cx, multicall_cv); \
if (++CvDEPTH(multicall_cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
} \
SAVECOMPPAD(); \
PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
PL_curpad = AvARRAY(PL_comppad); \
multicall_cop = CvSTART(multicall_cv); \
} STMT_END
#define MULTICALL \
STMT_START { \
PL_op = multicall_cop; \
CALLRUNOPS(aTHX); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
CvDEPTH(multicall_cv)--; \
LEAVESUB(multicall_cv); \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
LEAVE; \
SPAGAIN; \
} STMT_END
#endif