Author: coke
Date: Tue Aug 16 07:27:16 2005
New Revision: 8973
Modified:
trunk/languages/tcl/lib/commands/array.pir
trunk/languages/tcl/t/cmd_array.t
Log:
This patch should add a "get" sub into
languages/tcl/lib/commands/array.pir and enable the tests for it.
It should pass all of the Tcl tests.
Courtesy of "Amos Robinson"
Modified: trunk/languages/tcl/lib/commands/array.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/array.pir (original)
+++ trunk/languages/tcl/lib/commands/array.pir Tue Aug 16 07:27:16 2005
@@ -209,3 +209,84 @@ done:
.return (return_type,retval)
.end
+
+
+.include "iterator.pasm"
+.sub "get"
+ .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
+
+ retval = new String
+
+
+ .local int count
+ count = 0
+
+push_loop:
+ unless iter goto push_end
+ str = shift iter
+
+ # check for match
+ $P2 = rule(str)
+ unless $P2 goto push_loop
+
+ # if it's the first, we don't want to print a separating space
+ unless count goto skip_space
+ retval .= " "
+skip_space:
+ inc count
+ retval .= str
+ retval .= " "
+ val = the_array[str]
+ retval .= val
+
+ branch push_loop
+
+push_end:
+ .return (TCL_OK, retval)
+
+
+bad_args:
+ retval = new String
+ retval = "wrong # args: should be \"array get 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: trunk/languages/tcl/t/cmd_array.t
==============================================================================
--- trunk/languages/tcl/t/cmd_array.t (original)
+++ trunk/languages/tcl/t/cmd_array.t Tue Aug 16 07:27:16 2005
@@ -144,9 +144,6 @@ TCL
can't set "a(1)": variable isn't array
OUT
-TODO: {
- local $TODO = "unimplemented";
-
language_output_is("tcl",<<'TCL',<<'OUT',"array get");
array set a [list a b]
puts [array get a]
@@ -185,4 +182,3 @@ language_output_is("tcl",<<'TCL',<<'OUT'
TCL
wrong # args: should be "array get arrayName ?pattern?"
OUT
-}
