Author: mdiep
Date: Sat Aug 6 18:40:27 2005
New Revision: 8851
Added:
trunk/languages/tcl/lib/commands/lset.pir
trunk/languages/tcl/t/cmd_lset.t (contents, props changed)
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/tcl.in
Log:
tcl: Add [lset] (with tests).
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sat Aug 6 18:40:27 2005
@@ -1398,6 +1398,7 @@ languages/tcl/lib/commands/list.pir
languages/tcl/lib/commands/llength.pir [tcl]
languages/tcl/lib/commands/lrange.pir [tcl]
languages/tcl/lib/commands/lrepeat.pir [tcl]
+languages/tcl/lib/commands/lset.pir [tcl]
languages/tcl/lib/commands/namespace.pir [tcl]
languages/tcl/lib/commands/parray.pir [tcl]
languages/tcl/lib/commands/proc.pir [tcl]
Modified: trunk/config/gen/makefiles/tcl.in
==============================================================================
--- trunk/config/gen/makefiles/tcl.in (original)
+++ trunk/config/gen/makefiles/tcl.in Sat Aug 6 18:40:27 2005
@@ -43,6 +43,7 @@ lib${slash}commands${slash}list.pir \
lib${slash}commands${slash}llength.pir \
lib${slash}commands${slash}lrange.pir \
lib${slash}commands${slash}lrepeat.pir \
+lib${slash}commands${slash}lset.pir \
lib${slash}commands${slash}namespace.pir \
lib${slash}commands${slash}open.pir \
lib${slash}commands${slash}proc.pir \
Added: trunk/languages/tcl/lib/commands/lset.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/commands/lset.pir Sat Aug 6 18:40:27 2005
@@ -0,0 +1,80 @@
+#
+# [lset]
+#
+
+.namespace [ "Tcl" ]
+
+.sub "&lset"
+ .local pmc argv
+ argv = foldup
+
+ .local int return_type
+ .local pmc retval
+
+ $I0 = argv
+ if $I0 < 2 goto wrong_args
+
+ .local string name
+ $P0 = argv[0]
+ name = $P0
+
+ .local pmc read, set
+ read = find_global "_Tcl", "__read"
+ set = find_global "_Tcl", "__set"
+
+ (return_type, retval) = read(name)
+ if return_type == TCL_ERROR goto done
+
+ .local int count
+ count = argv
+ if count == 2 goto replace
+ $P0 = argv[1]
+ $S0 = $P0
+ if $S0 == "" goto replace
+
+lset:
+ .local pmc __list
+ __list = find_global "_Tcl", "__list"
+ (return_type, retval) = __list(retval)
+ if return_type == TCL_ERROR goto done
+
+ .local int i, end
+ i = 1
+ end = count - 2
+ .local pmc list
+ list = retval
+
+loop:
+ if i >= end goto loop_done
+
+ $I0 = argv[i]
+ $P0 = list[$I0]
+ (return_type, $P0) = __list($P0)
+ if return_type == TCL_ERROR goto done
+ list[$I0] = $P0
+ list = $P0
+
+ inc i
+ goto loop
+
+loop_done:
+ $I0 = argv[i]
+ $P0 = argv[-1]
+ list[$I0] = $P0
+ (return_type, retval) = set(name, retval)
+ goto done
+
+wrong_args:
+ return_type = TCL_ERROR
+ retval = new TclString
+ retval = "wrong # args: should be \"lset listVar index ?index...? value\""
+ goto done
+
+replace:
+ $P0 = argv[-1]
+ (return_type, retval) = set(name, $P0)
+ # goto done
+
+done:
+ .return(return_type, retval)
+.end
\ No newline at end of file
Added: trunk/languages/tcl/t/cmd_lset.t
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/t/cmd_lset.t Sat Aug 6 18:40:27 2005
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+use strict;
+use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
+use Parrot::Test tests => 4;
+
+language_output_is("tcl",<<'TCL',<<'OUT',"two arg replace");
+ set a "{"
+ puts [lset a b]
+TCL
+b
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"three arg replace");
+ set a "{"
+ puts [lset a {} b]
+TCL
+b
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"one index");
+ set a "a b c"
+ puts [lset a 1 c]
+TCL
+a c c
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"multiple indices");
+ set a "a {b c} d"
+ puts [lset a 1 0 c]
+TCL
+a {c c} d
+OUT
