Author: coke
Date: Wed Dec 28 18:20:21 2005
New Revision: 10757
Modified:
trunk/languages/tcl/lib/commands/string.pir
trunk/languages/tcl/t/cmd_string.t
Log:
#38058 : [PATCH] make [string last] work on tcl
implement [string tolower], [string last], [string toupper], adding
tests for all.
Courtesy Alberto Simoes <[EMAIL PROTECTED]>
Modified: trunk/languages/tcl/lib/commands/string.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/string.pir (original)
+++ trunk/languages/tcl/lib/commands/string.pir Wed Dec 28 18:20:21 2005
@@ -63,6 +63,54 @@ bad_args:
.end
+.sub "last"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 3 goto bad_args
+ if argc < 2 goto bad_args
+ $S1 = argv[0]
+ $S2 = argv[1]
+
+ $I0 = length $S2
+ if argc == 2 goto last_do
+
+ $S3 = argv[2]
+ .local pmc string_index
+ string_index = find_global "_Tcl", "__string_index"
+ $I1 = string_index($S3,$S2)
+
+ if $I1 > $I0 goto last_do
+ $I0 = $I1
+
+last_do:
+ .local int index_1
+ index_1 = index $S2, $S1, 0
+ if index_1 > $I0 goto not_found
+ if index_1 < 0 goto not_found
+
+iterate:
+ $I1 = index_1
+ $I2 = $I1 + 1
+ index_1 = index $S2, $S1, $I2
+ if index_1 < 0 goto return
+ if index_1 > $I0 goto return
+ goto iterate
+
+return:
+ .return($I1)
+
+not_found:
+ .return(-1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string last subString string
?lastIndex?\"")
+
+.end
+
.sub "index"
.param pmc argv
@@ -91,6 +139,110 @@ done:
.return (retval)
.end
+
+.sub "tolower"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 3 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $I1 = length $S1 # it will be useful
+
+ # If no range is specified, do to all the string
+ $I2 = 0
+ $I3 = $I1
+ if argc == 1 goto tolower_do
+
+ .local pmc string_index
+ string_index = find_global "_Tcl", "__string_index"
+
+ $S2 = argv[1]
+ $I2 = string_index($S2, $S1)
+ # if just the first is specified, the last is the same (tclsh says so)
+ $I3 = $I2
+ if argc == 2 goto tolower_do
+
+ $S3 = argv[2]
+ $I3 = string_index($S3, $S1)
+
+tolower_do:
+ if $I2 > $I1 goto tolower_return
+ if $I3 <= $I1 goto tolower_start
+ $I3 = $I1
+
+tolower_start:
+ $I4 = $I3 - $I2
+ $I4+= 1
+ $S2 = substr $S1, $I2, $I4
+ downcase $S2
+ substr $S1, $I2, $I4, $S2
+
+tolower_return:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string tolower string ?first? ?last?\"")
+
+.end
+
+
+
+.sub "toupper"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 3 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $I1 = length $S1 # it will be useful
+
+ # If no range is specified, do to all the string
+ $I2 = 0
+ $I3 = $I1
+ if argc == 1 goto toupper_do
+
+ .local pmc string_index
+ string_index = find_global "_Tcl", "__string_index"
+
+ $S2 = argv[1]
+ $I2 = string_index($S2, $S1)
+ # if just the first is specified, the last is the same (tclsh says so)
+ $I3 = $I2
+ if argc == 2 goto toupper_do
+
+ $S3 = argv[2]
+ $I3 = string_index($S3, $S1)
+
+toupper_do:
+ if $I2 > $I1 goto toupper_return
+ if $I3 <= $I1 goto toupper_start
+ $I3 = $I1
+
+toupper_start:
+ $I4 = $I3 - $I2
+ $I4+= 1
+ $S2 = substr $S1, $I2, $I4
+ upcase $S2
+ substr $S1, $I2, $I4, $S2
+
+toupper_return:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string toupper string ?first? ?last?\"")
+
+.end
+
+
.sub "bytelength"
.param pmc argv
Modified: trunk/languages/tcl/t/cmd_string.t
==============================================================================
--- trunk/languages/tcl/t/cmd_string.t (original)
+++ trunk/languages/tcl/t/cmd_string.t Wed Dec 28 18:20:21 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 82;
+use Parrot::Test tests => 92;
use Parrot::Config;
use Test::More;
@@ -72,9 +72,6 @@ TCL
wrong # args: should be "string first subString string ?startIndex?"
OUT
-TODO: {
- local $TODO = "implement string last";
-
language_output_is("tcl",<<TCL,<<OUT,"last, initial");
puts [string last a abcdefa]
TCL
@@ -100,21 +97,23 @@ TCL
OUT
language_output_is("tcl",<<TCL,<<OUT,"last, index, end");
- puts [string last c abcdc end-4]
+ puts [string last c abcdc end-2]
TCL
-4
+2
OUT
+## Overshot is ignored in this case as the maximum between the string
+## of the offset is considered
language_output_is("tcl",<<TCL,<<OUT,"last, index, overshot");
puts [string last c abcd 20]
TCL
--1
+2
OUT
language_output_is("tcl",<<TCL,<<OUT,"last, index");
puts [string last c abcdc 1]
TCL
-4
+-1
OUT
language_output_is("tcl",<<TCL,<<OUT,"last, index, invalid index");
@@ -126,17 +125,15 @@ OUT
language_output_is("tcl",<<TCL,<<OUT,"last, not enough args");
string last
TCL
-wrong # args: should be "string last subString string ?startIndex?"
+wrong # args: should be "string last subString string ?lastIndex?"
OUT
language_output_is("tcl",<<TCL,<<OUT,"last, too many args");
string last a b c d
TCL
-wrong # args: should be "string last subString string ?startIndex?"
+wrong # args: should be "string last subString string ?lastIndex?"
OUT
-}
-
language_output_is("tcl",<<TCL,<<OUT,"index, too many args");
string index a b c
TCL
@@ -459,6 +456,69 @@ TCL
OUT
}
+language_output_is("tcl",<<'TCL',<<OUT,"string tolower, Simple");
+ puts [string tolower "AabcD ABC"]
+TCL
+aabcd abc
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string tolower, bad args");
+ string tolower
+TCL
+wrong # args: should be "string tolower string ?first? ?last?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string tolower, both limits");
+ puts [string tolower PARROT end-4 4]
+TCL
+ParroT
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string tolower, single index");
+ puts [string tolower PARROT 4]
+TCL
+PARRoT
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string tolower, single index, out of
string");
+ puts [string tolower PARROT 40]
+TCL
+PARROT
+OUT
+
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string toupper, Simple");
+ puts [string toupper "AabcD ABC"]
+TCL
+AABCD ABC
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string toupper, bad args");
+ string toupper
+TCL
+wrong # args: should be "string toupper string ?first? ?last?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string toupper, both limits");
+ puts [string toupper parrot end-4 4]
+TCL
+pARROt
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string toupper, single index");
+ puts [string toupper parrot 4]
+TCL
+parrOt
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string toupper, single index, out of
string");
+ puts [string tolower parrot 40]
+TCL
+parrot
+OUT
+
+
# XXX - many of the classes are NOT tested here, and we rely
# on the cvs tests from tcl for that.
