develooper Front page | perl.perl5.porters | Postings from February 2000

[PATCH 5.5.660] improved semantics for assign to pseudohash

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.



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About