Author: coke
Date: Fri Aug 5 14:33:22 2005
New Revision: 8827
Modified:
trunk/languages/tcl/TODO
trunk/languages/tcl/lib/commands/array.pir
trunk/languages/tcl/t/cmd_array.t
Log:
tcl: convert [array] over to (modified) subcommand dispatch.
Add a few tests for [array], update the TODO list
Modified: trunk/languages/tcl/TODO
==============================================================================
--- trunk/languages/tcl/TODO (original)
+++ trunk/languages/tcl/TODO Fri Aug 5 14:33:22 2005
@@ -72,21 +72,8 @@ break the variable part out into array a
already doing that for us.
On a related note: No builtins or library code should be dealing with var
-sigils (i.e. C<$>) other than __set and __read.
-
-=item subcommand processing
-
-Convert any commands that use subcommands to [info] style dispatch to ease
-maintenance. Subcommands invoked in this style get a single container PMC
-with all their args, but *NOT* the invoking command. so, given the tcl:
-
- [info args foo]
-
-C<Tcl::info> is called with (args, foo), which then dispatched to:
-
-C<_Tcl::builtins::info::args((foo))>
-
-left: [array]
+sigils (i.e. C<$>) other than __set and __read {{ possibly array, since
+it needs to fetch the entire array: gen a new sub for this }}
=item implement default globals, etc.
Modified: trunk/languages/tcl/lib/commands/array.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/array.pir (original)
+++ trunk/languages/tcl/lib/commands/array.pir Fri Aug 5 14:33:22 2005
@@ -3,38 +3,53 @@
.namespace [ "Tcl" ]
+#
+# similar to but not exactly like [string]'s subcommand dispatch
+# - we pass in a boolean (array or not), the array itself, and the name
+# - we know we need an array name for *all* args, so we test for it here.
+
.sub "&array"
- .local pmc argv
+ .local pmc argv, retval
argv = foldup
.local int argc
argc = argv
- .local int return_type
- return_type = TCL_OK
- .local pmc retval
+ if argc < 2 goto few_args # subcommand *and* array name
+
+ .local string subcommand_name
+ subcommand_name = shift argv
+ .local pmc subcommand_proc
+ null subcommand_proc
+
+ push_eh catch
+ subcommand_proc = find_global "_Tcl\0builtins\0array", subcommand_name
+resume:
+ clear_eh
+ isnull subcommand_proc, bad_args
- if argc < 2 goto error
- .local string array_name,sigil_array_name
- .local pmc the_array
.local int is_array
+ .local string array_name, sigil_array_name
+ .local pmc the_array
- array_name = argv[1]
+ array_name = shift argv
sigil_array_name = "$" . array_name
.local int call_level
$P0 = find_global "_Tcl", "call_level"
call_level = $P0
+ null the_array
- push_eh catch
+ push_eh catch_var
if call_level goto find_lexical
the_array = find_global "Tcl", sigil_array_name
- goto resume
+ goto resume_var
find_lexical:
the_array = find_lex call_level, sigil_array_name
-resume:
+resume_var:
clear_eh
- catch:
+
+ catch_var:
isnull the_array, array_no
$I99 = does the_array, "hash"
@@ -47,49 +62,91 @@ array_no:
is_array = 0
scommand:
+ .return subcommand_proc(is_array,the_array,array_name,argv)
+
+catch:
+ goto resume
+
+bad_args:
+ retval = new String
+
+ retval = "bad option \""
+ retval .= subcommand_name
+ retval .= "\": must be anymore, donesearch, exists, get, names, nextelement,
set, size, startsearch, statistics, or unset"
+
+ .return(TCL_ERROR,retval)
+
+few_args:
+ retval = new String
+ retval = "wrong # args: should be \"array option arrayName ?arg ...?\""
+ .return (TCL_ERROR, retval)
+
+.end
+
+.namespace [ "_Tcl\0builtins\0array" ]
+
+.sub "exists"
+ .param int is_array
+ .param pmc the_array
+ .param string array_name
+ .param pmc argv
- .local string subcommand
- subcommand = argv[0]
+ .local int argc
+ argc = argv
+ if argc goto bad_args
- #if subcommand == "anymore" goto NOTDONEYET
- #if subcommand == "donesearch" goto NOTDONEYET
- if subcommand == "exists" goto exists
- #if subcommand == "get" goto NOTDONEYET
- #if subcommand == "names" goto NOTDONEYET
- #if subcommand == "nextelement" goto NOTDONEYET
- if subcommand == "set" goto set_it
- if subcommand == "size" goto size
- #if subcommand == "startsearch" goto NOTDONEYET
- #if subcommand == "statistics" goto NOTDONEYET
- #if subcommand == "unset" goto NOTDONEYET
-
- goto error
-
-# Is this really an array?
-exists:
- retval = new Integer
- retval = is_array
- goto done
+ $P1 = new Integer
+ $P1 = is_array
+ .return (TCL_OK, $P1)
+
+bad_args:
+ $P1 = new String
+ $P1 = "wrong # args: should be \"array exists arrayName\""
+ .return (TCL_ERROR, $P1)
+.end
+
+.sub "size"
+ .param int is_array
+ .param pmc the_array
+ .param string array_name
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+ if argc goto bad_args
-size:
- retval = new Integer
if is_array == 0 goto size_none
$I0 = the_array
- retval = $I0
- goto done
+ $P1 = new Integer
+ $P1 = $I0
+ .return (TCL_OK, $P1)
+
size_none:
- retval = 0
- goto done
+ $P1 = new Integer
+ $P1 = 0
+ .return (TCL_OK, $P1)
+
+bad_args:
+ $P1 = new String
+ $P1 = "wrong # args: should be \"array size arrayName\""
+ .return (TCL_ERROR, $P1)
+.end
-set_it:
- # array_name is getting stomped on here
- # print "array name: '"
- # print array_name
- # print "'\n"
- if argc != 3 goto set_bad_args
+.sub "set"
+ .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 int return_type
+ .local pmc retval
.local pmc elems
- elems = argv[2]
+ elems = argv[0]
.local pmc __list
__list = find_global "_Tcl", "__list"
@@ -97,11 +154,11 @@ set_it:
if return_type == TCL_ERROR goto done
elems = retval
-set_pre_loop:
+pre_loop:
.local int count
count = elems
$I0 = count % 2
- if $I0 == 1 goto set_odd_args
+ if $I0 == 1 goto odd_args
# pull out all the key/value pairs and set them.
.local int loop
@@ -109,20 +166,11 @@ set_pre_loop:
.local string key
.local string val
- # see if there's an existing array with this name to add to
- # and if not create a new array
- push_eh set_new_array
- if call_level goto get_lex
- the_array = find_global "Tcl", sigil_array_name
- goto set_has_array
- get_lex:
- the_array = find_lex call_level, sigil_array_name
-set_has_array:
- clear_eh
+ isnull the_array, new_array
goto set_loop
-set_new_array:
- the_array = new TclArray
+new_array:
+ the_array = new .TclArray
set_loop:
key = elems[loop]
@@ -140,27 +188,19 @@ set_loop:
retval = new String
retval = ""
- goto done
+ .return (TCL_OK, retval)
-
-set_bad_args:
- return_type = TCL_ERROR
+bad_args:
retval = new String
retval = "wrong # args: should be array set arrayName list"
- goto done
+ .return (TCL_ERROR, retval)
-set_odd_args:
- return_type = TCL_ERROR
+odd_args:
retval = new String
retval = "list must have an even number of elements"
- goto done
-
-error:
- # XXX - this isn't the right error message.
- print "Bad call to array: \n"
- goto done
+ .return (TCL_ERROR, retval)
done:
- .return(return_type,retval)
+ .return (return_type,retval)
.end
Modified: trunk/languages/tcl/t/cmd_array.t
==============================================================================
--- trunk/languages/tcl/t/cmd_array.t (original)
+++ trunk/languages/tcl/t/cmd_array.t Fri Aug 5 14:33:22 2005
@@ -2,10 +2,28 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 13;
+use Parrot::Test tests => 18;
use Test::More;
use vars qw($TODO);
+language_output_is("tcl",<<'TCL',<<OUT,"array, no args");
+ array
+TCL
+wrong # args: should be "array option arrayName ?arg ...?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"array, good subcommand, no array");
+ array exists
+TCL
+wrong # args: should be "array option arrayName ?arg ...?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"array, bad subcommand, bad arary");
+ array bork foo
+TCL
+bad option "bork": must be anymore, donesearch, exists, get, names,
nextelement, set, size, startsearch, statistics, or unset
+OUT
+
language_output_is("tcl",<<'TCL',<<OUT,"array exists yes");
set b(c) 2
puts [array exists b]
@@ -26,6 +44,18 @@ TCL
0
OUT
+language_output_is("tcl",<<'TCL',<<OUT,"array exists too many args");
+ puts [array exists a b]
+TCL
+wrong # args: should be "array exists arrayName"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"array size too many args");
+ array size a b
+TCL
+wrong # args: should be "array size arrayName"
+OUT
+
language_output_is("tcl",<<'TCL',<<OUT,"array size 1");
set a(1) 1
puts [array size a]
