From: Nicholas Clark Date: Thu, 20 Dec 2007 21:15:57 +0000 (+0000) Subject: Implement each @array. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=878d132a73f5d089e821fedd49aa4835a2786d1d;p=p5sagit%2Fp5-mst-13.2.git Implement each @array. Documentation needed, FIXME for proper 64 bit support of arrays longer than 2**32, re-order the new ops at the end if merging to 5.10.x. p4raw-id: //depot/perl@32680 --- diff --git a/MANIFEST b/MANIFEST index 03a20b4..3a0f6b1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3798,6 +3798,7 @@ t/op/die.t See if die works t/op/dor.t See if defined-or (//) works t/op/do.t See if subroutines work t/op/each.t See if hash iterators work +t/op/each_array.t See if array iterators work t/op/eval.t See if eval operator works t/op/exec.t See if exec, system and qx work t/op/exists_sub.t See if exists(&sub) works diff --git a/av.c b/av.c index 116b7aa..d528ffc 100644 --- a/av.c +++ b/av.c @@ -945,8 +945,8 @@ Perl_av_exists(pTHX_ AV *av, I32 key) return FALSE; } -SV ** -Perl_av_arylen_p(pTHX_ AV *av) { +MAGIC * +S_get_aux_mg(pTHX_ AV *av) { dVAR; MAGIC *mg; @@ -961,9 +961,22 @@ Perl_av_arylen_p(pTHX_ AV *av) { /* sv_magicext won't set this for us because we pass in a NULL obj */ mg->mg_flags |= MGf_REFCOUNTED; } + return mg; +} + +SV ** +Perl_av_arylen_p(pTHX_ AV *av) { + MAGIC *const mg = get_aux_mg(av); return &(mg->mg_obj); } +/* This will change to returning IV ** at some point soon */ +I32 * +Perl_av_iter_p(pTHX_ AV *av) { + MAGIC *const mg = get_aux_mg(av); + return &(mg->mg_len); +} + /* * Local variables: * c-indentation-style: bsd diff --git a/embed.fnc b/embed.fnc index a5a191d..bcbb009 100644 --- a/embed.fnc +++ b/embed.fnc @@ -115,6 +115,10 @@ Apd |void |av_undef |NN AV* ar ApdoxM |SV** |av_create_and_unshift_one|NN AV **const avp|NN SV *const val Apd |void |av_unshift |NN AV* ar|I32 num Apo |SV** |av_arylen_p |NN AV* av +AMpo |I32* |av_iter_p |NN AV* av +#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) +s |MAGIC* |get_aux_mg |NN AV *av +#endif pR |OP* |bind_match |I32 type|NN OP* left|NN OP* pat pR |OP* |block_end |I32 floor|NULLOK OP* seq ApR |I32 |block_gimme @@ -1215,6 +1219,7 @@ pR |OP* |ck_substr |NN OP *o pR |OP* |ck_svconst |NN OP *o pR |OP* |ck_trunc |NN OP *o pR |OP* |ck_unpack |NN OP *o +pR |OP* |ck_each |NN OP *o sRn |bool |is_handle_constructor|NN const OP *o|I32 numargs sR |I32 |is_list_assignment|NULLOK const OP *o # ifdef USE_ITHREADS diff --git a/embed.h b/embed.h index 81a08ee..2eebd81 100644 --- a/embed.h +++ b/embed.h @@ -71,6 +71,11 @@ #define av_store Perl_av_store #define av_undef Perl_av_undef #define av_unshift Perl_av_unshift +#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define get_aux_mg S_get_aux_mg +#endif +#endif #ifdef PERL_CORE #define bind_match Perl_bind_match #define block_end Perl_block_end @@ -1204,6 +1209,7 @@ #define ck_svconst Perl_ck_svconst #define ck_trunc Perl_ck_trunc #define ck_unpack Perl_ck_unpack +#define ck_each Perl_ck_each #define is_handle_constructor S_is_handle_constructor #define is_list_assignment S_is_list_assignment #endif @@ -1931,6 +1937,7 @@ #define ck_defined Perl_ck_defined #define ck_delete Perl_ck_delete #define ck_die Perl_ck_die +#define ck_each Perl_ck_each #define ck_eof Perl_ck_eof #define ck_eval Perl_ck_eval #define ck_exec Perl_ck_exec @@ -1971,6 +1978,7 @@ #define pp_abs Perl_pp_abs #define pp_accept Perl_pp_accept #define pp_add Perl_pp_add +#define pp_aeach Perl_pp_aeach #define pp_aelem Perl_pp_aelem #define pp_aelemfast Perl_pp_aelemfast #define pp_alarm Perl_pp_alarm @@ -2370,6 +2378,11 @@ #define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c) #define av_undef(a) Perl_av_undef(aTHX_ a) #define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b) +#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define get_aux_mg(a) S_get_aux_mg(aTHX_ a) +#endif +#endif #ifdef PERL_CORE #define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c) #define block_end(a,b) Perl_block_end(aTHX_ a,b) @@ -3489,6 +3502,7 @@ #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) #define ck_unpack(a) Perl_ck_unpack(aTHX_ a) +#define ck_each(a) Perl_ck_each(aTHX_ a) #define is_handle_constructor S_is_handle_constructor #define is_list_assignment(a) S_is_list_assignment(aTHX_ a) #endif @@ -4231,6 +4245,7 @@ #define ck_defined(a) Perl_ck_defined(aTHX_ a) #define ck_delete(a) Perl_ck_delete(aTHX_ a) #define ck_die(a) Perl_ck_die(aTHX_ a) +#define ck_each(a) Perl_ck_each(aTHX_ a) #define ck_eof(a) Perl_ck_eof(aTHX_ a) #define ck_eval(a) Perl_ck_eval(aTHX_ a) #define ck_exec(a) Perl_ck_exec(aTHX_ a) @@ -4271,6 +4286,7 @@ #define pp_abs() Perl_pp_abs(aTHX) #define pp_accept() Perl_pp_accept(aTHX) #define pp_add() Perl_pp_add(aTHX) +#define pp_aeach() Perl_pp_aeach(aTHX) #define pp_aelem() Perl_pp_aelem(aTHX) #define pp_aelemfast() Perl_pp_aelemfast(aTHX) #define pp_alarm() Perl_pp_alarm(aTHX) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index e0078e5..b552f90 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.11"; +$VERSION = "1.12"; use Carp; use Exporter (); @@ -310,7 +310,7 @@ invert_opset function. rv2av aassign aelem aelemfast aslice av2arylen - rv2hv helem hslice each values keys exists delete + rv2hv helem hslice each values keys exists delete aeach akeys avalues preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec int hex oct abs pow multiply i_multiply divide i_divide diff --git a/op.c b/op.c index e68b86f..bb6ac62 100644 --- a/op.c +++ b/op.c @@ -7892,6 +7892,27 @@ Perl_ck_substr(pTHX_ OP *o) return o; } +OP * +Perl_ck_each(pTHX_ OP *o) +{ + + OP *kid = cLISTOPo->op_first; + + if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { + const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH + : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; + o->op_type = new_type; + o->op_ppaddr = PL_ppaddr[new_type]; + } + else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV + || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) + )) { + bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); + return o; + } + return ck_fun(o); +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ diff --git a/opcode.h b/opcode.h index 76df85c..a7ca152 100644 --- a/opcode.h +++ b/opcode.h @@ -163,6 +163,9 @@ EXTCONST char* const PL_op_name[] = { "aelemfast", "aelem", "aslice", + "aeach", + "akeys", + "avalues", "each", "values", "keys", @@ -532,6 +535,9 @@ EXTCONST char* const PL_op_desc[] = { "constant array element", "array element", "array slice", + "each on array", + "keys on array", + "values on array", "each", "values", "keys", @@ -915,6 +921,9 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ MEMBER_TO_FPTR(Perl_pp_aelemfast), MEMBER_TO_FPTR(Perl_pp_aelem), MEMBER_TO_FPTR(Perl_pp_aslice), + MEMBER_TO_FPTR(Perl_pp_aeach), + MEMBER_TO_FPTR(Perl_pp_akeys), + MEMBER_TO_FPTR(Perl_pp_akeys), /* Perl_pp_avalues */ MEMBER_TO_FPTR(Perl_pp_each), MEMBER_TO_FPTR(Perl_do_kv), /* Perl_pp_values */ MEMBER_TO_FPTR(Perl_do_kv), /* Perl_pp_keys */ @@ -1295,9 +1304,12 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ MEMBER_TO_FPTR(Perl_ck_null), /* aelemfast */ MEMBER_TO_FPTR(Perl_ck_null), /* aelem */ MEMBER_TO_FPTR(Perl_ck_null), /* aslice */ - MEMBER_TO_FPTR(Perl_ck_fun), /* each */ - MEMBER_TO_FPTR(Perl_ck_fun), /* values */ - MEMBER_TO_FPTR(Perl_ck_fun), /* keys */ + MEMBER_TO_FPTR(Perl_ck_each), /* aeach */ + MEMBER_TO_FPTR(Perl_ck_each), /* akeys */ + MEMBER_TO_FPTR(Perl_ck_each), /* avalues */ + MEMBER_TO_FPTR(Perl_ck_each), /* each */ + MEMBER_TO_FPTR(Perl_ck_each), /* values */ + MEMBER_TO_FPTR(Perl_ck_each), /* keys */ MEMBER_TO_FPTR(Perl_ck_delete), /* delete */ MEMBER_TO_FPTR(Perl_ck_exists), /* exists */ MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2hv */ @@ -1669,6 +1681,9 @@ EXTCONST U32 PL_opargs[] = { 0x00026c04, /* aelemfast */ 0x00026404, /* aelem */ 0x00046801, /* aslice */ + 0x00007600, /* aeach */ + 0x00007608, /* akeys */ + 0x00007608, /* avalues */ 0x00009600, /* each */ 0x00009608, /* values */ 0x00009608, /* keys */ diff --git a/opcode.pl b/opcode.pl index 854996d..c65ced3 100755 --- a/opcode.pl +++ b/opcode.pl @@ -91,6 +91,7 @@ my @raw_alias = ( Perl_pp_sin => [qw(cos exp log sqrt)], Perl_pp_bit_or => ['bit_xor'], Perl_pp_rv2av => ['rv2hv'], + Perl_pp_akeys => ['avalues'], ); while (my ($func, $names) = splice @raw_alias, 0, 2) { @@ -736,11 +737,15 @@ aelemfast constant array element ck_null s$ A S aelem array element ck_null s2 A S aslice array slice ck_null m@ A L +aeach each on array ck_each % A +akeys keys on array ck_each t% A +avalues values on array ck_each t% A + # Hashes. -each each ck_fun % H -values values ck_fun t% H -keys keys ck_fun t% H +each each ck_each % H +values values ck_each t% H +keys keys ck_each t% H delete delete ck_delete % S exists exists ck_exists is% S rv2hv hash dereference ck_rvconst dt1 diff --git a/opnames.h b/opnames.h index d2633e6..e0585fb 100644 --- a/opnames.h +++ b/opnames.h @@ -145,242 +145,245 @@ typedef enum opcode { OP_AELEMFAST, /* 127 */ OP_AELEM, /* 128 */ OP_ASLICE, /* 129 */ - OP_EACH, /* 130 */ - OP_VALUES, /* 131 */ - OP_KEYS, /* 132 */ - OP_DELETE, /* 133 */ - OP_EXISTS, /* 134 */ - OP_RV2HV, /* 135 */ - OP_HELEM, /* 136 */ - OP_HSLICE, /* 137 */ - OP_UNPACK, /* 138 */ - OP_PACK, /* 139 */ - OP_SPLIT, /* 140 */ - OP_JOIN, /* 141 */ - OP_LIST, /* 142 */ - OP_LSLICE, /* 143 */ - OP_ANONLIST, /* 144 */ - OP_ANONHASH, /* 145 */ - OP_SPLICE, /* 146 */ - OP_PUSH, /* 147 */ - OP_POP, /* 148 */ - OP_SHIFT, /* 149 */ - OP_UNSHIFT, /* 150 */ - OP_SORT, /* 151 */ - OP_REVERSE, /* 152 */ - OP_GREPSTART, /* 153 */ - OP_GREPWHILE, /* 154 */ - OP_MAPSTART, /* 155 */ - OP_MAPWHILE, /* 156 */ - OP_RANGE, /* 157 */ - OP_FLIP, /* 158 */ - OP_FLOP, /* 159 */ - OP_AND, /* 160 */ - OP_OR, /* 161 */ - OP_XOR, /* 162 */ - OP_DOR, /* 163 */ - OP_COND_EXPR, /* 164 */ - OP_ANDASSIGN, /* 165 */ - OP_ORASSIGN, /* 166 */ - OP_DORASSIGN, /* 167 */ - OP_METHOD, /* 168 */ - OP_ENTERSUB, /* 169 */ - OP_LEAVESUB, /* 170 */ - OP_LEAVESUBLV, /* 171 */ - OP_CALLER, /* 172 */ - OP_WARN, /* 173 */ - OP_DIE, /* 174 */ - OP_RESET, /* 175 */ - OP_LINESEQ, /* 176 */ - OP_NEXTSTATE, /* 177 */ - OP_DBSTATE, /* 178 */ - OP_UNSTACK, /* 179 */ - OP_ENTER, /* 180 */ - OP_LEAVE, /* 181 */ - OP_SCOPE, /* 182 */ - OP_ENTERITER, /* 183 */ - OP_ITER, /* 184 */ - OP_ENTERLOOP, /* 185 */ - OP_LEAVELOOP, /* 186 */ - OP_RETURN, /* 187 */ - OP_LAST, /* 188 */ - OP_NEXT, /* 189 */ - OP_REDO, /* 190 */ - OP_DUMP, /* 191 */ - OP_GOTO, /* 192 */ - OP_EXIT, /* 193 */ - OP_SETSTATE, /* 194 */ - OP_METHOD_NAMED,/* 195 */ - OP_ENTERGIVEN, /* 196 */ - OP_LEAVEGIVEN, /* 197 */ - OP_ENTERWHEN, /* 198 */ - OP_LEAVEWHEN, /* 199 */ - OP_BREAK, /* 200 */ - OP_CONTINUE, /* 201 */ - OP_OPEN, /* 202 */ - OP_CLOSE, /* 203 */ - OP_PIPE_OP, /* 204 */ - OP_FILENO, /* 205 */ - OP_UMASK, /* 206 */ - OP_BINMODE, /* 207 */ - OP_TIE, /* 208 */ - OP_UNTIE, /* 209 */ - OP_TIED, /* 210 */ - OP_DBMOPEN, /* 211 */ - OP_DBMCLOSE, /* 212 */ - OP_SSELECT, /* 213 */ - OP_SELECT, /* 214 */ - OP_GETC, /* 215 */ - OP_READ, /* 216 */ - OP_ENTERWRITE, /* 217 */ - OP_LEAVEWRITE, /* 218 */ - OP_PRTF, /* 219 */ - OP_PRINT, /* 220 */ - OP_SAY, /* 221 */ - OP_SYSOPEN, /* 222 */ - OP_SYSSEEK, /* 223 */ - OP_SYSREAD, /* 224 */ - OP_SYSWRITE, /* 225 */ - OP_SEND, /* 226 */ - OP_RECV, /* 227 */ - OP_EOF, /* 228 */ - OP_TELL, /* 229 */ - OP_SEEK, /* 230 */ - OP_TRUNCATE, /* 231 */ - OP_FCNTL, /* 232 */ - OP_IOCTL, /* 233 */ - OP_FLOCK, /* 234 */ - OP_SOCKET, /* 235 */ - OP_SOCKPAIR, /* 236 */ - OP_BIND, /* 237 */ - OP_CONNECT, /* 238 */ - OP_LISTEN, /* 239 */ - OP_ACCEPT, /* 240 */ - OP_SHUTDOWN, /* 241 */ - OP_GSOCKOPT, /* 242 */ - OP_SSOCKOPT, /* 243 */ - OP_GETSOCKNAME, /* 244 */ - OP_GETPEERNAME, /* 245 */ - OP_LSTAT, /* 246 */ - OP_STAT, /* 247 */ - OP_FTRREAD, /* 248 */ - OP_FTRWRITE, /* 249 */ - OP_FTREXEC, /* 250 */ - OP_FTEREAD, /* 251 */ - OP_FTEWRITE, /* 252 */ - OP_FTEEXEC, /* 253 */ - OP_FTIS, /* 254 */ - OP_FTSIZE, /* 255 */ - OP_FTMTIME, /* 256 */ - OP_FTATIME, /* 257 */ - OP_FTCTIME, /* 258 */ - OP_FTROWNED, /* 259 */ - OP_FTEOWNED, /* 260 */ - OP_FTZERO, /* 261 */ - OP_FTSOCK, /* 262 */ - OP_FTCHR, /* 263 */ - OP_FTBLK, /* 264 */ - OP_FTFILE, /* 265 */ - OP_FTDIR, /* 266 */ - OP_FTPIPE, /* 267 */ - OP_FTSUID, /* 268 */ - OP_FTSGID, /* 269 */ - OP_FTSVTX, /* 270 */ - OP_FTLINK, /* 271 */ - OP_FTTTY, /* 272 */ - OP_FTTEXT, /* 273 */ - OP_FTBINARY, /* 274 */ - OP_CHDIR, /* 275 */ - OP_CHOWN, /* 276 */ - OP_CHROOT, /* 277 */ - OP_UNLINK, /* 278 */ - OP_CHMOD, /* 279 */ - OP_UTIME, /* 280 */ - OP_RENAME, /* 281 */ - OP_LINK, /* 282 */ - OP_SYMLINK, /* 283 */ - OP_READLINK, /* 284 */ - OP_MKDIR, /* 285 */ - OP_RMDIR, /* 286 */ - OP_OPEN_DIR, /* 287 */ - OP_READDIR, /* 288 */ - OP_TELLDIR, /* 289 */ - OP_SEEKDIR, /* 290 */ - OP_REWINDDIR, /* 291 */ - OP_CLOSEDIR, /* 292 */ - OP_FORK, /* 293 */ - OP_WAIT, /* 294 */ - OP_WAITPID, /* 295 */ - OP_SYSTEM, /* 296 */ - OP_EXEC, /* 297 */ - OP_KILL, /* 298 */ - OP_GETPPID, /* 299 */ - OP_GETPGRP, /* 300 */ - OP_SETPGRP, /* 301 */ - OP_GETPRIORITY, /* 302 */ - OP_SETPRIORITY, /* 303 */ - OP_TIME, /* 304 */ - OP_TMS, /* 305 */ - OP_LOCALTIME, /* 306 */ - OP_GMTIME, /* 307 */ - OP_ALARM, /* 308 */ - OP_SLEEP, /* 309 */ - OP_SHMGET, /* 310 */ - OP_SHMCTL, /* 311 */ - OP_SHMREAD, /* 312 */ - OP_SHMWRITE, /* 313 */ - OP_MSGGET, /* 314 */ - OP_MSGCTL, /* 315 */ - OP_MSGSND, /* 316 */ - OP_MSGRCV, /* 317 */ - OP_SEMOP, /* 318 */ - OP_SEMGET, /* 319 */ - OP_SEMCTL, /* 320 */ - OP_REQUIRE, /* 321 */ - OP_DOFILE, /* 322 */ - OP_ENTEREVAL, /* 323 */ - OP_LEAVEEVAL, /* 324 */ - OP_ENTERTRY, /* 325 */ - OP_LEAVETRY, /* 326 */ - OP_GHBYNAME, /* 327 */ - OP_GHBYADDR, /* 328 */ - OP_GHOSTENT, /* 329 */ - OP_GNBYNAME, /* 330 */ - OP_GNBYADDR, /* 331 */ - OP_GNETENT, /* 332 */ - OP_GPBYNAME, /* 333 */ - OP_GPBYNUMBER, /* 334 */ - OP_GPROTOENT, /* 335 */ - OP_GSBYNAME, /* 336 */ - OP_GSBYPORT, /* 337 */ - OP_GSERVENT, /* 338 */ - OP_SHOSTENT, /* 339 */ - OP_SNETENT, /* 340 */ - OP_SPROTOENT, /* 341 */ - OP_SSERVENT, /* 342 */ - OP_EHOSTENT, /* 343 */ - OP_ENETENT, /* 344 */ - OP_EPROTOENT, /* 345 */ - OP_ESERVENT, /* 346 */ - OP_GPWNAM, /* 347 */ - OP_GPWUID, /* 348 */ - OP_GPWENT, /* 349 */ - OP_SPWENT, /* 350 */ - OP_EPWENT, /* 351 */ - OP_GGRNAM, /* 352 */ - OP_GGRGID, /* 353 */ - OP_GGRENT, /* 354 */ - OP_SGRENT, /* 355 */ - OP_EGRENT, /* 356 */ - OP_GETLOGIN, /* 357 */ - OP_SYSCALL, /* 358 */ - OP_LOCK, /* 359 */ - OP_ONCE, /* 360 */ - OP_CUSTOM, /* 361 */ + OP_AEACH, /* 130 */ + OP_AKEYS, /* 131 */ + OP_AVALUES, /* 132 */ + OP_EACH, /* 133 */ + OP_VALUES, /* 134 */ + OP_KEYS, /* 135 */ + OP_DELETE, /* 136 */ + OP_EXISTS, /* 137 */ + OP_RV2HV, /* 138 */ + OP_HELEM, /* 139 */ + OP_HSLICE, /* 140 */ + OP_UNPACK, /* 141 */ + OP_PACK, /* 142 */ + OP_SPLIT, /* 143 */ + OP_JOIN, /* 144 */ + OP_LIST, /* 145 */ + OP_LSLICE, /* 146 */ + OP_ANONLIST, /* 147 */ + OP_ANONHASH, /* 148 */ + OP_SPLICE, /* 149 */ + OP_PUSH, /* 150 */ + OP_POP, /* 151 */ + OP_SHIFT, /* 152 */ + OP_UNSHIFT, /* 153 */ + OP_SORT, /* 154 */ + OP_REVERSE, /* 155 */ + OP_GREPSTART, /* 156 */ + OP_GREPWHILE, /* 157 */ + OP_MAPSTART, /* 158 */ + OP_MAPWHILE, /* 159 */ + OP_RANGE, /* 160 */ + OP_FLIP, /* 161 */ + OP_FLOP, /* 162 */ + OP_AND, /* 163 */ + OP_OR, /* 164 */ + OP_XOR, /* 165 */ + OP_DOR, /* 166 */ + OP_COND_EXPR, /* 167 */ + OP_ANDASSIGN, /* 168 */ + OP_ORASSIGN, /* 169 */ + OP_DORASSIGN, /* 170 */ + OP_METHOD, /* 171 */ + OP_ENTERSUB, /* 172 */ + OP_LEAVESUB, /* 173 */ + OP_LEAVESUBLV, /* 174 */ + OP_CALLER, /* 175 */ + OP_WARN, /* 176 */ + OP_DIE, /* 177 */ + OP_RESET, /* 178 */ + OP_LINESEQ, /* 179 */ + OP_NEXTSTATE, /* 180 */ + OP_DBSTATE, /* 181 */ + OP_UNSTACK, /* 182 */ + OP_ENTER, /* 183 */ + OP_LEAVE, /* 184 */ + OP_SCOPE, /* 185 */ + OP_ENTERITER, /* 186 */ + OP_ITER, /* 187 */ + OP_ENTERLOOP, /* 188 */ + OP_LEAVELOOP, /* 189 */ + OP_RETURN, /* 190 */ + OP_LAST, /* 191 */ + OP_NEXT, /* 192 */ + OP_REDO, /* 193 */ + OP_DUMP, /* 194 */ + OP_GOTO, /* 195 */ + OP_EXIT, /* 196 */ + OP_SETSTATE, /* 197 */ + OP_METHOD_NAMED,/* 198 */ + OP_ENTERGIVEN, /* 199 */ + OP_LEAVEGIVEN, /* 200 */ + OP_ENTERWHEN, /* 201 */ + OP_LEAVEWHEN, /* 202 */ + OP_BREAK, /* 203 */ + OP_CONTINUE, /* 204 */ + OP_OPEN, /* 205 */ + OP_CLOSE, /* 206 */ + OP_PIPE_OP, /* 207 */ + OP_FILENO, /* 208 */ + OP_UMASK, /* 209 */ + OP_BINMODE, /* 210 */ + OP_TIE, /* 211 */ + OP_UNTIE, /* 212 */ + OP_TIED, /* 213 */ + OP_DBMOPEN, /* 214 */ + OP_DBMCLOSE, /* 215 */ + OP_SSELECT, /* 216 */ + OP_SELECT, /* 217 */ + OP_GETC, /* 218 */ + OP_READ, /* 219 */ + OP_ENTERWRITE, /* 220 */ + OP_LEAVEWRITE, /* 221 */ + OP_PRTF, /* 222 */ + OP_PRINT, /* 223 */ + OP_SAY, /* 224 */ + OP_SYSOPEN, /* 225 */ + OP_SYSSEEK, /* 226 */ + OP_SYSREAD, /* 227 */ + OP_SYSWRITE, /* 228 */ + OP_SEND, /* 229 */ + OP_RECV, /* 230 */ + OP_EOF, /* 231 */ + OP_TELL, /* 232 */ + OP_SEEK, /* 233 */ + OP_TRUNCATE, /* 234 */ + OP_FCNTL, /* 235 */ + OP_IOCTL, /* 236 */ + OP_FLOCK, /* 237 */ + OP_SOCKET, /* 238 */ + OP_SOCKPAIR, /* 239 */ + OP_BIND, /* 240 */ + OP_CONNECT, /* 241 */ + OP_LISTEN, /* 242 */ + OP_ACCEPT, /* 243 */ + OP_SHUTDOWN, /* 244 */ + OP_GSOCKOPT, /* 245 */ + OP_SSOCKOPT, /* 246 */ + OP_GETSOCKNAME, /* 247 */ + OP_GETPEERNAME, /* 248 */ + OP_LSTAT, /* 249 */ + OP_STAT, /* 250 */ + OP_FTRREAD, /* 251 */ + OP_FTRWRITE, /* 252 */ + OP_FTREXEC, /* 253 */ + OP_FTEREAD, /* 254 */ + OP_FTEWRITE, /* 255 */ + OP_FTEEXEC, /* 256 */ + OP_FTIS, /* 257 */ + OP_FTSIZE, /* 258 */ + OP_FTMTIME, /* 259 */ + OP_FTATIME, /* 260 */ + OP_FTCTIME, /* 261 */ + OP_FTROWNED, /* 262 */ + OP_FTEOWNED, /* 263 */ + OP_FTZERO, /* 264 */ + OP_FTSOCK, /* 265 */ + OP_FTCHR, /* 266 */ + OP_FTBLK, /* 267 */ + OP_FTFILE, /* 268 */ + OP_FTDIR, /* 269 */ + OP_FTPIPE, /* 270 */ + OP_FTSUID, /* 271 */ + OP_FTSGID, /* 272 */ + OP_FTSVTX, /* 273 */ + OP_FTLINK, /* 274 */ + OP_FTTTY, /* 275 */ + OP_FTTEXT, /* 276 */ + OP_FTBINARY, /* 277 */ + OP_CHDIR, /* 278 */ + OP_CHOWN, /* 279 */ + OP_CHROOT, /* 280 */ + OP_UNLINK, /* 281 */ + OP_CHMOD, /* 282 */ + OP_UTIME, /* 283 */ + OP_RENAME, /* 284 */ + OP_LINK, /* 285 */ + OP_SYMLINK, /* 286 */ + OP_READLINK, /* 287 */ + OP_MKDIR, /* 288 */ + OP_RMDIR, /* 289 */ + OP_OPEN_DIR, /* 290 */ + OP_READDIR, /* 291 */ + OP_TELLDIR, /* 292 */ + OP_SEEKDIR, /* 293 */ + OP_REWINDDIR, /* 294 */ + OP_CLOSEDIR, /* 295 */ + OP_FORK, /* 296 */ + OP_WAIT, /* 297 */ + OP_WAITPID, /* 298 */ + OP_SYSTEM, /* 299 */ + OP_EXEC, /* 300 */ + OP_KILL, /* 301 */ + OP_GETPPID, /* 302 */ + OP_GETPGRP, /* 303 */ + OP_SETPGRP, /* 304 */ + OP_GETPRIORITY, /* 305 */ + OP_SETPRIORITY, /* 306 */ + OP_TIME, /* 307 */ + OP_TMS, /* 308 */ + OP_LOCALTIME, /* 309 */ + OP_GMTIME, /* 310 */ + OP_ALARM, /* 311 */ + OP_SLEEP, /* 312 */ + OP_SHMGET, /* 313 */ + OP_SHMCTL, /* 314 */ + OP_SHMREAD, /* 315 */ + OP_SHMWRITE, /* 316 */ + OP_MSGGET, /* 317 */ + OP_MSGCTL, /* 318 */ + OP_MSGSND, /* 319 */ + OP_MSGRCV, /* 320 */ + OP_SEMOP, /* 321 */ + OP_SEMGET, /* 322 */ + OP_SEMCTL, /* 323 */ + OP_REQUIRE, /* 324 */ + OP_DOFILE, /* 325 */ + OP_ENTEREVAL, /* 326 */ + OP_LEAVEEVAL, /* 327 */ + OP_ENTERTRY, /* 328 */ + OP_LEAVETRY, /* 329 */ + OP_GHBYNAME, /* 330 */ + OP_GHBYADDR, /* 331 */ + OP_GHOSTENT, /* 332 */ + OP_GNBYNAME, /* 333 */ + OP_GNBYADDR, /* 334 */ + OP_GNETENT, /* 335 */ + OP_GPBYNAME, /* 336 */ + OP_GPBYNUMBER, /* 337 */ + OP_GPROTOENT, /* 338 */ + OP_GSBYNAME, /* 339 */ + OP_GSBYPORT, /* 340 */ + OP_GSERVENT, /* 341 */ + OP_SHOSTENT, /* 342 */ + OP_SNETENT, /* 343 */ + OP_SPROTOENT, /* 344 */ + OP_SSERVENT, /* 345 */ + OP_EHOSTENT, /* 346 */ + OP_ENETENT, /* 347 */ + OP_EPROTOENT, /* 348 */ + OP_ESERVENT, /* 349 */ + OP_GPWNAM, /* 350 */ + OP_GPWUID, /* 351 */ + OP_GPWENT, /* 352 */ + OP_SPWENT, /* 353 */ + OP_EPWENT, /* 354 */ + OP_GGRNAM, /* 355 */ + OP_GGRGID, /* 356 */ + OP_GGRENT, /* 357 */ + OP_SGRENT, /* 358 */ + OP_EGRENT, /* 359 */ + OP_GETLOGIN, /* 360 */ + OP_SYSCALL, /* 361 */ + OP_LOCK, /* 362 */ + OP_ONCE, /* 363 */ + OP_CUSTOM, /* 364 */ OP_max } opcode; -#define MAXO 362 +#define MAXO 365 #define OP_phoney_INPUT_ONLY -1 #define OP_phoney_OUTPUT_ONLY -2 diff --git a/pp.c b/pp.c index 6d69589..f5ff461 100644 --- a/pp.c +++ b/pp.c @@ -3929,6 +3929,67 @@ PP(pp_aslice) RETURN; } +PP(pp_aeach) +{ + dVAR; + dSP; + AV *array = (AV*)POPs; + const I32 gimme = GIMME_V; + I32 *iterp = Perl_av_iter_p(aTHX_ array); + const IV current = (*iterp)++; + + if (current > av_len(array)) { + *iterp = 0; + if (gimme == G_SCALAR) + RETPUSHUNDEF; + else + RETURN; + } + + EXTEND(SP, 2); + mPUSHi(CopARYBASE_get(PL_curcop) + current); + if (gimme == G_ARRAY) { + SV **const element = av_fetch(array, current, 0); + PUSHs(element ? *element : &PL_sv_undef); + } + RETURN; +} + +PP(pp_akeys) +{ + dVAR; + dSP; + AV *array = (AV*)POPs; + const I32 gimme = GIMME_V; + + *Perl_av_iter_p(aTHX_ array) = 0; + + if (gimme == G_SCALAR) { + dTARGET; + PUSHi(av_len(array) + 1); + } + else if (gimme == G_ARRAY) { + IV n = Perl_av_len(aTHX_ array); + IV i = CopARYBASE_get(PL_curcop); + + EXTEND(SP, n + 1); + + if (PL_op->op_type == OP_AKEYS) { + n += i; + for (; i <= n; i++) { + mPUSHi(i); + } + } + else { + for (i = 0; i <= n; i++) { + SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); + PUSHs(elem ? *elem : &PL_sv_undef); + } + } + } + RETURN; +} + /* Associative arrays. */ PP(pp_each) diff --git a/pp.sym b/pp.sym index f5136ea..fad5f6e 100644 --- a/pp.sym +++ b/pp.sym @@ -12,6 +12,7 @@ Perl_ck_concat Perl_ck_defined Perl_ck_delete Perl_ck_die +Perl_ck_each Perl_ck_eof Perl_ck_eval Perl_ck_exec @@ -174,6 +175,9 @@ Perl_pp_rv2av Perl_pp_aelemfast Perl_pp_aelem Perl_pp_aslice +Perl_pp_aeach +Perl_pp_akeys +Perl_pp_avalues Perl_pp_each Perl_pp_values Perl_pp_keys diff --git a/pp_proto.h b/pp_proto.h index 3a96e32..e40122e 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -11,6 +11,7 @@ PERL_CKDEF(Perl_ck_concat) PERL_CKDEF(Perl_ck_defined) PERL_CKDEF(Perl_ck_delete) PERL_CKDEF(Perl_ck_die) +PERL_CKDEF(Perl_ck_each) PERL_CKDEF(Perl_ck_eof) PERL_CKDEF(Perl_ck_eval) PERL_CKDEF(Perl_ck_exec) @@ -175,6 +176,9 @@ PERL_PPDEF(Perl_pp_rv2av) PERL_PPDEF(Perl_pp_aelemfast) PERL_PPDEF(Perl_pp_aelem) PERL_PPDEF(Perl_pp_aslice) +PERL_PPDEF(Perl_pp_aeach) +PERL_PPDEF(Perl_pp_akeys) +PERL_PPDEF(Perl_pp_avalues) PERL_PPDEF(Perl_pp_each) PERL_PPDEF(Perl_pp_values) PERL_PPDEF(Perl_pp_keys) diff --git a/proto.h b/proto.h index 1aec27a..574fcc8 100644 --- a/proto.h +++ b/proto.h @@ -189,6 +189,14 @@ PERL_CALLCONV void Perl_av_unshift(pTHX_ AV* ar, I32 num) PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV* av) __attribute__nonnull__(pTHX_1); +PERL_CALLCONV I32* Perl_av_iter_p(pTHX_ AV* av) + __attribute__nonnull__(pTHX_1); + +#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) +STATIC MAGIC* S_get_aux_mg(pTHX_ AV *av) + __attribute__nonnull__(pTHX_1); + +#endif PERL_CALLCONV OP* Perl_bind_match(pTHX_ I32 type, OP* left, OP* pat) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2) @@ -3264,6 +3272,10 @@ PERL_CALLCONV OP* Perl_ck_unpack(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); +PERL_CALLCONV OP* Perl_ck_each(pTHX_ OP *o) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); + STATIC bool S_is_handle_constructor(const OP *o, I32 numargs) __attribute__warn_unused_result__ __attribute__nonnull__(1); diff --git a/t/op/each_array.t b/t/op/each_array.t new file mode 100644 index 0000000..b0665e1 --- /dev/null +++ b/t/op/each_array.t @@ -0,0 +1,132 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} +use strict; +use vars qw(@array @r $k $v); + +plan tests => 48; + +@array = qw(crunch zam bloop); + +(@r) = each @array; +is (scalar @r, 2); +is ($r[0], 0); +is ($r[1], 'crunch'); +($k, $v) = each @array; +is ($k, 1); +is ($v, 'zam'); +($k, $v) = each @array; +is ($k, 2); +is ($v, 'bloop'); +(@r) = each @array; +is (scalar @r, 0); + +(@r) = each @array; +is (scalar @r, 2); +is ($r[0], 0); +is ($r[1], 'crunch'); +($k) = each @array; +is ($k, 1); +{ + $[ = 2; + my ($k, $v) = each @array; + is ($k, 4); + is ($v, 'bloop'); + (@r) = each @array; + is (scalar @r, 0); +} + +my @lex_array = qw(PLOP SKLIZZORCH RATTLE PBLRBLPSFT); + +(@r) = each @lex_array; +is (scalar @r, 2); +is ($r[0], 0); +is ($r[1], 'PLOP'); +($k, $v) = each @lex_array; +is ($k, 1); +is ($v, 'SKLIZZORCH'); +($k) = each @lex_array; +is ($k, 2); +{ + $[ = -42; + my ($k, $v) = each @lex_array; + is ($k, -39); + is ($v, 'PBLRBLPSFT'); +} +(@r) = each @lex_array; +is (scalar @r, 0); + +my $ar = ['bacon']; + +(@r) = each @$ar; +is (scalar @r, 2); +is ($r[0], 0); +is ($r[1], 'bacon'); + +(@r) = each @$ar; +is (scalar @r, 0); + +is (each @$ar, 0); +is (scalar each @$ar, undef); + +my @keys; +@keys = keys @array; +is ("@keys", "0 1 2"); + +@keys = keys @lex_array; +is ("@keys", "0 1 2 3"); + +{ + $[ = 1; + + @keys = keys @array; + is ("@keys", "1 2 3"); + + @keys = keys @lex_array; + is ("@keys", "1 2 3 4"); +} + +($k, $v) = each @array; +is ($k, 0); +is ($v, 'crunch'); + +@keys = keys @array; +is ("@keys", "0 1 2"); + +($k, $v) = each @array; +is ($k, 0); +is ($v, 'crunch'); + + + +my @values; +@values = values @array; +is ("@values", "@array"); + +@values = values @lex_array; +is ("@values", "@lex_array"); + +{ + $[ = 1; + + @values = values @array; + is ("@values", "@array"); + + @values = values @lex_array; + is ("@values", "@lex_array"); +} + +($k, $v) = each @array; +is ($k, 0); +is ($v, 'crunch'); + +@values = values @array; +is ("@values", "@array"); + +($k, $v) = each @array; +is ($k, 0); +is ($v, 'crunch');