-
Notifications
You must be signed in to change notification settings - Fork 6
/
subs.c
216 lines (180 loc) · 6.18 KB
/
subs.c
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
/*
Data-Util/subs.c
XS code templates for curry() and modify_subroutine()
*/
#include "data-util.h"
MGVTBL curried_vtbl;
MGVTBL modified_vtbl;
MAGIC*
my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){
MAGIC* mg;
for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
if(mg->mg_virtual == vtbl){
break;
}
}
return mg;
}
XS(XS_Data__Util_curried){
dVAR; dXSARGS;
MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &curried_vtbl);
assert(mg);
SP -= items;
/*
NOTE:
Curried subroutines have two properties, "params" and "phs"(placeholders).
Geven a curried subr created by "curry(\&f, $x, *_, $y, \0)":
params: [ $x, undef, $y, undef]
phs: [undef, *_, undef, 0]
Here the curried subr is called with arguments.
Firstly, the arguments are set to params, expanding subscriptive placeholders,
but the placeholder "*_" is set to the end of params.
params: [ $x, undef, $y, $_[0], @_ ]
Then, params are pushed into SP, expanding "*_".
SP: [ $x, @_[1..$#_], $y, $_[0] ]
Finally, params are cleand up.
params: [ $x, undef, $y, undef ]
*/
{
AV* const params = (AV*)mg->mg_obj;
SV** params_ary = AvARRAY(params);
I32 const len = AvFILLp(params) + 1;
AV* const phs = (AV*)mg->mg_ptr; /* placeholders */
SV**const phs_ary = AvARRAY(phs);
I32 max_ph = -1; /* max placeholder index */
I32 min_ph = items; /* min placeholder index */
SV** sph = NULL; // indicates *_
U16 const is_method = mg->mg_private; /* G_METHOD */
I32 push_size = len - 1; /* -1: proc */
register I32 i;
SV* proc;
/* fill in params */
for(i = 0; i < len; i++){
SV* const ph = phs_ary[i];
if(isGV(ph)){ /* symbolic placeholder *_ */
if(!sph){
I32 j;
if(AvMAX(params) < (len + items)){
av_extend(params, len + items);
params_ary = AvARRAY(params); /* maybe realloc()-ed */
}
/*
All the arguments @_ is pushed into the end of params,
not calling SvREFCNT_inc().
*/
sph = ¶ms_ary[len];
for(j = 0; j < items; j++){
/* NOTE: no need to SvREFCNT_inc(ST(j)),
* bacause AvFILLp(params) remains len-1.
* That's okey.
*/
sph[j] = ST(j);
}
}
push_size += items;
}
else if(SvIOKp(ph)){ /* subscriptive placeholders */
IV p = SvIVX(ph);
if(p >= 0){
if(p > max_ph) max_ph = p;
}
else{ /* negative index */
p += items;
if(p < 0){
Perl_croak(aTHX_ PL_no_aelem, (int)p);
}
if(p < min_ph) min_ph = p;
}
if(p <= items){
/* NOTE: no need to SvREFCNT_inc(params_ary[i]),
* because it removed from params_ary before call_sv()
*/
params_ary[i] = ST(p);
}
}
}
PUSHMARK(SP);
EXTEND(SP, push_size);
if(is_method){
PUSHs( params_ary[0] ); /* invocant */
proc = params_ary[1]; /* method */
i = 2;
}
else{
proc = params_ary[0]; /* code ref */
i = 1;
}
for(/* i is initialized above */; i < len; i++){
if(isGV(phs_ary[i])){
/* warn("#sph %d - %d", (int)max_ph+1, (int)min_ph); //*/
PUSHary(sph, max_ph + 1, min_ph);
}
else{
PUSHs(params_ary[i]);
}
}
PUTBACK;
/* NOTE: need to clean up params before call_sv(), because call_sv() might die */
for(i = 0; i < len; i++){
if(SvIOKp(phs_ary[i])){
/* NOTE: no need to SvREFCNT_dec(params_ary[i]) */
params_ary[i] = &PL_sv_undef;
}
}
/* G_EVAL to workaround RT #69939 */
call_sv(proc, GIMME_V | is_method | G_EVAL);
if(SvTRUEx(ERRSV)){
croak(NULL); /* rethrow */
}
}
}
/* call an av of cv with args_ary */
static void
my_call_av(pTHX_ AV* const subs, SV** const args_ary, I32 const args_len){
I32 const subs_len = AvFILLp(subs) + 1;
I32 i;
for(i = 0; i < subs_len; i++){
dSP;
PUSHMARK(SP);
XPUSHary(args_ary, 0, args_len);
PUTBACK;
/* G_EVAL to workaround RT #69939 */
call_sv(AvARRAY(subs)[i], G_VOID | G_DISCARD | G_EVAL);
if(SvTRUEx(ERRSV)){
croak(NULL);
}
}
}
XS(XS_Data__Util_modified){
dVAR; dXSARGS;
MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &modified_vtbl);
assert(mg);
SP -= items;
{
AV* const subs_av = (AV*)mg->mg_obj;
AV* const before = (AV*)AvARRAY(subs_av)[M_BEFORE];
SV* const current = (SV*)AvARRAY(subs_av)[M_CURRENT];
AV* const after = (AV*)AvARRAY(subs_av)[M_AFTER];
I32 i;
dXSTARG;
AV* const args = (AV*)TARG;
SV** args_ary;
(void)SvUPGRADE(TARG, SVt_PVAV);
if(AvMAX(args) < items){
av_extend(args, items);
}
args_ary = AvARRAY(args);
for(i = 0; i < items; i++){
args_ary[i] = ST(i); /* no need to SvREFCNT_inc() */
}
PUTBACK;
my_call_av(aTHX_ before, args_ary, items);
SPAGAIN;
PUSHMARK(SP);
XPUSHary(args_ary, 0, items);
PUTBACK;
call_sv(current, GIMME_V);
my_call_av(aTHX_ after, args_ary, items);
}
/* no need to XSRETURN(n) */
}