Author: leo
Date: Sat Aug 20 02:58:38 2005
New Revision: 9005
Modified:
branches/leo-ctx5/languages/tcl/lib/commands/array.pir
branches/leo-ctx5/languages/tcl/t/cmd_array.t
branches/leo-ctx5/src/hash.c
Log:
merge -r9000:9004 from trunk
Modified: branches/leo-ctx5/languages/tcl/lib/commands/array.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/array.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/array.pir Sat Aug 20
02:58:38 2005
@@ -290,3 +290,68 @@ not_array:
.return(TCL_ERROR, retval)
.end
+.sub "unset"
+ .param int is_array
+ .param pmc the_array
+ .param string array_name
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+ if argc > 1 goto bad_args
+
+
+ .local string match_str
+ # ?pattern? defaults to matching everything.
+ match_str = "*"
+
+ # if it's there, get it from the arglist
+ if argc == 0 goto no_args
+ match_str = shift argv
+
+no_args:
+ if is_array == 0 goto not_array
+
+ .local pmc retval
+
+ .local pmc iter, val
+ .local string str
+
+ .local pmc globber
+
+ globber = find_global "PGE", "glob"
+ .local pmc rule
+ (rule, $P0, $P1) = globber(match_str)
+
+ iter = new Iterator, the_array
+ iter = .ITERATE_FROM_START
+
+push_loop:
+ unless iter goto push_end
+ str = shift iter
+
+ # check for match
+ $P2 = rule(str)
+ unless $P2 goto push_loop
+
+ delete the_array[str]
+
+ branch push_loop
+push_end:
+
+ retval = new String
+ retval = ""
+ .return (TCL_OK, retval)
+
+
+bad_args:
+ retval = new String
+ retval = "wrong # args: should be \"array unset arrayName ?pattern?\""
+ .return(TCL_ERROR, retval)
+
+not_array:
+ retval = new String
+ retval = ""
+ # is there a better way to do this?
+ .return(TCL_ERROR, retval)
+.end
Modified: branches/leo-ctx5/languages/tcl/t/cmd_array.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/cmd_array.t (original)
+++ branches/leo-ctx5/languages/tcl/t/cmd_array.t Sat Aug 20 02:58:38 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 25;
+use Parrot::Test tests => 33;
use vars qw($TODO);
language_output_is("tcl",<<'TCL',<<OUT,"array, no args");
@@ -164,6 +164,13 @@ TCL
apple 1 aardvark 3
OUT
+language_output_is("tcl",<<'TCL',<<'OUT',"array get, with bad pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array get a zippy*]
+TCL
+
+OUT
+
language_output_is("tcl",<<'TCL',<<'OUT',"array get, bad array");
puts [array get a]
TCL
@@ -181,3 +188,57 @@ language_output_is("tcl",<<'TCL',<<'OUT'
TCL
wrong # args: should be "array get arrayName ?pattern?"
OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset");
+ array set a [list a b]
+ puts [array unset a]
+ puts [array get a]
+TCL
+
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with pattern");
+ array set a [list a b c d]
+ puts [array unset a a]
+ puts [array get a]
+TCL
+
+c d
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array unset a a*]
+ puts [array get a]
+TCL
+
+orange 2
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with bad pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array unset a zippy*]
+ puts [array get a]
+TCL
+
+apple 1 orange 2 aardvark 3
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, bad array");
+ puts [array unset badarray]
+TCL
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, bad array, pattern");
+ puts [array unset badarray monkey*]
+TCL
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, too many args");
+ array unset monkey my monkey monkey
+TCL
+wrong # args: should be "array unset arrayName ?pattern?"
+OUT
Modified: branches/leo-ctx5/src/hash.c
==============================================================================
--- branches/leo-ctx5/src/hash.c (original)
+++ branches/leo-ctx5/src/hash.c Sat Aug 20 02:58:38 2005
@@ -14,7 +14,7 @@ creation the types of key and value as w
hashing functions can be set.
This hash implementation uses just one piece of malloced memory. The
-C<hash->bu> union points into this regions. At positive indices are
+C<< hash->bu >> union points into this regions. At positive indices are
bucket pointers, at negative indices is the bucket store itself.
This hash doesn't move during GC, therefore a lot of the old caveats
@@ -573,7 +573,7 @@ init_hash(Interp *interpreter, Hash *has
bp->key = bp->value = NULL;
hash->free_list = bp;
}
- /* see the grafic in expand_hash */
+ /* see the graphic in expand_hash */
hash->bu.bs = bp;
for (i = 0; i < INITIAL_BUCKETS; ++i) {
hash->bu.bi[i] = NULL;
@@ -683,7 +683,7 @@ hash_get_idx(Interp *interpreter, Hash *
void *res;
/* idx directly in the bucket store, which is at negative
- * addressess from the data pointer
+ * address from the data pointer
*/
/* locate initial */
if (bi == INITBucketIndex) {
@@ -972,7 +972,7 @@ Future optimizations:
=item * Stop reallocating the bucket pool, and instead add chunks on.
(Saves pointer fixups and copying during C<realloc>.)
-=item * Hash contraction (dunno if it's worth it)
+=item * Hash contraction (don't if it's worth it)
=back
