Front page | perl.perl5.porters |
Postings from February 2000
[PATCH 5.5.660] improved semantics for assign to pseudohash
Thread Previous
|
Thread Next
From:
John Tobey
Date:
February 26, 2000 15:19
Subject:
[PATCH 5.5.660] improved semantics for assign to pseudohash
Message ID:
m12OqUJ-000FPGC@feynman.localnet
Hi,
This patch addresses (mostly, I think) an issue Michael Schwern raised in
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-02/msg00040.html
('What should %$pseudo_hash = (); do?')
Here are the added tests, which show what my patch does:
$avhv = [{foo=>1,bar=>2,pants=>3}];
%$avhv = ();
print "not " unless ref($avhv->[0]) eq 'HASH';
print "ok 21\n";
%hv = %$avhv;
print "not " if grep defined, values %hv;
print "ok 22\n";
print "not " if grep ref, keys %hv;
print "ok 23\n";
%$avhv = (foo => 29, pants => 2, bar => 0);
print "not " unless "@$avhv[1..3]" eq '29 0 2';
print "ok 24\n";
There are still some weirdnesses affecting pseudohashes. This kind of
thing
(%$ph, $x) = (@bla);
gives the old behavior of C<%$ph = (@bla)>, not the new; this is
fixable with some extra code in Perl_ck_aassign.
NOTE: This patch may be too unstable to apply so close to 5.6. All
tests pass, but I am not certain that the assumptions about op type in
Perl_ck_aassign are justified. I'd like to check my changes in
pp_aassign for memory leakage. I have actually changed the prototype
and semantics of a public avhv function, Perl_avhv_fetch_ent. (The
final argument seemed non-useful, was never used in the source, and
since the interface is 'experimental' and undocumented, I think it
better to change it now than to add a differently named function.)
Other pseudohash-related changes that I may get around to are:
- optimize hash slice of a single key, so this will not be
unexpectedly slow:
my Dog $spot = Dog->new;
@$spot{
'collar',
# 'bone', # commented out
} = (@spots);
- use %FIELDS for compile-time key checking in slices when ANY key
is constant, not only when all are constant.
- use %FIELDS for key checking in list assignments to typed hash
derefs like:
%$ph = (foo => $foo, baa => bar());
A fuzzier idea is to allow fields to be typed, so something like
BEGIN {
%Dog::FIELDS = (
teeth => 1,
tail => 2,
fur => [ 3, 'Fur' ]
);
%Fur::FIELDS = (
color => 1,
fleas => 2
);
}
my Dog $spot;
sub spots_fleas {
return $spot->{fur}->{fleas};
}
would be optimized to C<$spot->[3]->[2]> without requiring an extra
variable of type Fur.
Note that applying the below patch requires running `make
regen_headers' after ./Configure.
-John
--
John Tobey, late nite hacker <jtobey@john-edwin-tobey.org>
\\\ ///
]]] With enough bugs, all eyes are shallow. [[[
/// \\\
diff -ur perl5.5.660/Makefile.SH perl5.5.660.john/Makefile.SH
--- perl5.5.660/Makefile.SH Tue Feb 22 23:38:14 2000
+++ perl5.5.660.john/Makefile.SH Sat Feb 26 02:25:15 2000
@@ -621,7 +621,7 @@
embedvar.h global.sym pod/perlintern.pod pod/perlapi.pod \
objXSUB.h perlapi.h perlapi.c ext/ByteLoader/byterun.h \
ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm regnodes.h \
- warnings.h lib/warnings.pm
+ warnings.h lib/warnings.pm proto.h
regen_headers: FORCE
$(CHMOD_W) $(AUTOGEN_FILES)
diff -ur perl5.5.660/av.c perl5.5.660.john/av.c
--- perl5.5.660/av.c Tue Feb 22 23:38:14 2000
+++ perl5.5.660.john/av.c Sat Feb 26 05:02:51 2000
@@ -805,6 +805,20 @@
return index;
}
+STATIC I32
+S_avhv_index(pTHX_ AV *av, SV *keysv, HV *keys)
+{
+ HE *he;
+ STRLEN n_a;
+
+ if (!keys)
+ keys = avhv_keys(av);
+ he = hv_fetch_ent(keys, keysv, FALSE, 0);
+ if (!he)
+ Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
+ return avhv_index_sv(HeVAL(he));
+}
+
HV*
Perl_avhv_keys(pTHX_ AV *av)
{
@@ -824,17 +838,15 @@
}
SV**
-Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
+Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, HV *keys)
{
- SV **indsvp;
- HV *keys = avhv_keys(av);
- HE *he;
- STRLEN n_a;
-
- he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (!he)
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
- return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+ return av_store(av, avhv_index(av, keysv, keys), val);
+}
+
+SV**
+Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, HV *keys)
+{
+ return av_fetch(av, avhv_index(av, keysv, keys), lval);
}
SV *
diff -ur perl5.5.660/embed.pl perl5.5.660.john/embed.pl
--- perl5.5.660/embed.pl Tue Feb 22 23:38:15 2000
+++ perl5.5.660.john/embed.pl Sat Feb 26 04:50:27 2000
@@ -1351,7 +1351,8 @@
p |I32 |apply |I32 type|SV** mark|SV** sp
Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
-Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash
+Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|HV* hash
+Ap |SV** |avhv_store_ent |AV *ar|SV* keysv|SV* val|HV* hash
Ap |HE* |avhv_iternext |AV *ar
Ap |SV* |avhv_iterval |AV *ar|HE* entry
Ap |HV* |avhv_keys |AV *ar
@@ -2153,6 +2154,7 @@
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
s |I32 |avhv_index_sv |SV* sv
+s |I32 |avhv_index |AV* av|SV* sv|HV* keys
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
diff -ur perl5.5.660/op.c perl5.5.660.john/op.c
--- perl5.5.660/op.c Tue Feb 22 23:38:17 2000
+++ perl5.5.660.john/op.c Sat Feb 26 06:30:34 2000
@@ -5713,7 +5713,7 @@
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
- OP *kid = cLISTOPo->op_first;
+ OP *kid = cBINOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
@@ -5730,13 +5730,23 @@
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN. */
kid->op_sibling = o->op_sibling; /* NULL */
- cLISTOPo->op_first = NULL;
+ cBINOPo->op_first = NULL;
op_free(o);
op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_aassign(pTHX_ OP *o)
+{
+ OP *kid;
+ kid = ((LISTOP*)cBINOPo->op_first->op_sibling)->op_last;
+ if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV)
+ o->op_flags |= OPf_SPECIAL;
return o;
}
diff -ur perl5.5.660/op.h perl5.5.660.john/op.h
--- perl5.5.660/op.h Sun Feb 6 14:32:59 2000
+++ perl5.5.660.john/op.h Sat Feb 26 01:35:09 2000
@@ -95,6 +95,7 @@
/* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
/* On OP_ENTERITER, loop var is per-thread */
/* On pushre, re is /\s+/ imp. by split " " */
+ /* On OP_AASSIGN, left side is a hash. */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
diff -ur perl5.5.660/opcode.pl perl5.5.660.john/opcode.pl
--- perl5.5.660/opcode.pl Tue Feb 22 23:38:17 2000
+++ perl5.5.660.john/opcode.pl Sat Feb 26 01:33:03 2000
@@ -398,7 +398,7 @@
# sassign is special-cased for op class
sassign scalar assignment ck_sassign s0
-aassign list assignment ck_null t2 L L
+aassign list assignment ck_aassign t2 L L
chop chop ck_spair mts% L
schop scalar chop ck_null stu% S?
diff -ur perl5.5.660/pp_hot.c perl5.5.660.john/pp_hot.c
--- perl5.5.660/pp_hot.c Tue Feb 22 23:38:18 2000
+++ perl5.5.660.john/pp_hot.c Sat Feb 26 06:42:57 2000
@@ -636,7 +636,7 @@
register AV *ary;
I32 gimme;
- HV *hash;
+ HV *hash, *keys;
I32 i;
int magic;
@@ -668,27 +668,52 @@
case SVt_PVAV:
ary = (AV*)sv;
magic = SvMAGICAL(ary) != 0;
-
- av_clear(ary);
- av_extend(ary, lastrelem - relem);
- i = 0;
- while (relem <= lastrelem) { /* gobble up all the rest */
- SV **didstore;
- sv = NEWSV(28,0);
- assert(*relem);
- sv_setsv(sv,*relem);
- *(relem++) = sv;
- didstore = av_store(ary,i++,sv);
- if (magic) {
- if (SvSMAGICAL(sv))
- mg_set(sv);
- if (!didstore)
- sv_2mortal(sv);
+ if (PL_op->op_flags & OPf_SPECIAL) { /* pseudohash */
+ if (av_len(ary) > 0)
+ av_fill(ary, 0); /* clear all but the fields hash */
+ if (lastrelem >= relem) {
+ keys = avhv_keys(ary);
+ while (relem < lastrelem) { /* gobble up all the rest */
+ SV *tmpstr;
+ assert(relem[0]);
+ assert(relem[1]);
+ /* Avoid a memory leak when avhv_store_ent dies. */
+ tmpstr = sv_newmortal();
+ sv_setsv(tmpstr,relem[1]); /* value */
+ relem[1] = tmpstr;
+ if (avhv_store_ent(ary,relem[0],tmpstr,keys))
+ SvREFCNT_inc(tmpstr);
+ if (magic && SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ relem += 2;
+ }
+ TAINT_NOT;
+ }
+ if (relem == lastrelem)
+ goto oddball;
+ }
+ else { /* array */
+ av_clear(ary);
+ av_extend(ary, lastrelem - relem);
+ i = 0;
+ while (relem <= lastrelem) { /* gobble up all the rest */
+ SV **didstore;
+ sv = NEWSV(28,0);
+ assert(*relem);
+ sv_setsv(sv,*relem);
+ *(relem++) = sv;
+ didstore = av_store(ary,i++,sv);
+ if (magic) {
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
+ if (!didstore)
+ sv_2mortal(sv);
+ }
+ TAINT_NOT;
}
- TAINT_NOT;
}
break;
- case SVt_PVHV: {
+ case SVt_PVHV: { /* normal hash */
SV *tmpstr;
hash = (HV*)sv;
@@ -715,6 +740,7 @@
TAINT_NOT;
}
if (relem == lastrelem) {
+ oddball:
if (*relem) {
HE *didstore;
if (ckWARN(WARN_MISC)) {
@@ -726,13 +752,22 @@
else
Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
}
- tmpstr = NEWSV(29,0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (magic) {
- if (SvSMAGICAL(tmpstr))
+ if (SvTYPE(sv) == SVt_PVAV) { /* pseudohash */
+ tmpstr = sv_newmortal();
+ if (avhv_store_ent(ary,*relem,tmpstr,keys))
+ SvREFCNT_inc(tmpstr);
+ if (magic && SvSMAGICAL(tmpstr))
mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
+ }
+ else {
+ tmpstr = NEWSV(29,0);
+ didstore = hv_store_ent(hash,*relem,tmpstr,0);
+ if (magic) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ sv_2mortal(tmpstr);
+ }
}
TAINT_NOT;
}
@@ -828,7 +863,7 @@
SETi(lastrelem - firstrelem + 1);
}
else {
- if (ary || hash)
+ if (ary || hash || keys)
SP = lastrelem;
else
SP = firstrelem + (lastlelem - firstlelem);
diff -ur perl5.5.660/t/op/avhv.t perl5.5.660.john/t/op/avhv.t
--- perl5.5.660/t/op/avhv.t Thu Jan 13 01:42:53 2000
+++ perl5.5.660.john/t/op/avhv.t Sat Feb 26 16:44:00 2000
@@ -17,7 +17,7 @@
package main;
-print "1..20\n";
+print "1..24\n";
$sch = {
'abc' => 1,
@@ -90,7 +90,7 @@
$avhv = [];
eval { $a = %$avhv };
-print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
+print "not " unless $@ and $@ =~ /^Can't coerce array into hash/; #'
print "ok 9\n";
$avhv = [{foo=>1, bar=>2}];
@@ -139,3 +139,18 @@
print "not " unless "$avhv->{bar}" eq "yyy";
print "ok 20\n";
+
+# hash assignment
+%$avhv = ();
+print "not " unless ref($avhv->[0]) eq 'HASH';
+print "ok 21\n";
+
+%hv = %$avhv;
+print "not " if grep defined, values %hv;
+print "ok 22\n";
+print "not " if grep ref, keys %hv;
+print "ok 23\n";
+
+%$avhv = (foo => 29, pants => 2, bar => 0);
+print "not " unless "@$avhv[1..3]" eq '29 0 2';
+print "ok 24\n";
diff -ur perl5.5.660/t/op/hashwarn.t perl5.5.660.john/t/op/hashwarn.t
--- perl5.5.660/t/op/hashwarn.t Tue Jul 20 13:18:14 1999
+++ perl5.5.660.john/t/op/hashwarn.t Sat Feb 26 16:53:41 2000
@@ -14,7 +14,7 @@
# ...and save 'em as we go
$SIG{'__WARN__'} = sub { push @warnings, @_ };
$| = 1;
- print "1..7\n";
+ print "1..9\n";
}
END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings }
@@ -66,6 +66,13 @@
%hash = sub { print "ok" };
test_warning 6, shift @warnings, $odd_msg;
+ my $avhv = [{x=>1,y=>2}];
+ %$avhv = (x=>13,'y');
+ test_warning 7, shift @warnings, $odd_msg;
+
+ %$avhv = 'x';
+ test_warning 8, shift @warnings, $odd_msg;
+
$_ = { 1..10 };
- test 7, ! @warnings, "Unexpected warning";
+ test 9, ! @warnings, "Unexpected warning";
}
End of Patch.
Thread Previous
|
Thread Next