Author: coke
Date: Thu Aug 4 08:33:32 2005
New Revision: 8808
Modified:
trunk/languages/tcl/lib/tclconst.pir
trunk/languages/tcl/t/tcl_backslash.t
Log:
Pass all partcl unicode tests (need to expect utf8), fix bug in processing
multiple \'s in a single word, add a test for it.
Modified: trunk/languages/tcl/lib/tclconst.pir
==============================================================================
--- trunk/languages/tcl/lib/tclconst.pir (original)
+++ trunk/languages/tcl/lib/tclconst.pir Thu Aug 4 08:33:32 2005
@@ -70,7 +70,6 @@ Define the attributes required for the c
.param string value
.local int value_length
- value_length = length value
.local pmc backslashes, hexadecimal
find_global backslashes, "_Tcl", "backslashes"
@@ -79,6 +78,7 @@ Define the attributes required for the c
.local int pos
pos = 0
loop:
+ value_length = length value
pos = index value, "\\", pos
if pos == -1 goto done
@@ -125,7 +125,7 @@ octal_only1:
$S0 = chr octal_value
substr value, pos, 2, $S0
- pos += 2 # skip \ and 1 char.
+ inc pos
goto loop
octal2:
@@ -148,7 +148,7 @@ octal_only2:
$S0 = chr octal_value
substr value, pos, 3, $S0
- pos += 3 # skip \ and 2 characters
+ inc pos
goto loop
octal3:
@@ -161,8 +161,7 @@ octal3:
$S0 = chr octal_value
substr value, pos, 4, $S0
- pos += 4 # skip \ and 3 characters
-
+ inc pos
goto loop # can't have four digits, stop now.
=for comment
@@ -198,13 +197,14 @@ hex_done:
$S0 = chr hex_value
substr value, pos, $I0, $S0
- pos = hex_pos
+ inc pos
+
goto loop
hex_not_really:
# This was a \x escape that had no hex value..
substr value, pos, 2, "x"
- pos = hex_pos
+ inc pos
goto loop
=for comment
@@ -241,17 +241,15 @@ uni_done:
$S0 = chr uni_value
substr value, pos, $I0, $S0
- pos = uni_pos
+ inc pos
goto loop
uni_not_really:
- # This was a \x escape that had no uni value..
+ # This was a \u escape that had no uni value..
substr value, pos, 2, "u"
- pos = uni_pos
+ inc pos
goto loop
-
-
special:
$S0 = backslashes[$I0]
substr value, pos, 2, $S0
Modified: trunk/languages/tcl/t/tcl_backslash.t
==============================================================================
--- trunk/languages/tcl/t/tcl_backslash.t (original)
+++ trunk/languages/tcl/t/tcl_backslash.t Thu Aug 4 08:33:32 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 34;
+use Parrot::Test tests => 35;
use Test::More;
my($tcl,$expected);
@@ -68,105 +68,105 @@ EOTCL
$expected = "a b\n";
language_output_is("tcl",$tcl,$expected,"backslash newline substitution");
-language_output_is("tcl",<<'TCL',<<OUT,"octal single char");
+language_output_is("tcl",<<'TCL',<<OUT,"octal single digit");
set a \7
puts $a
TCL
\cG
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"octal single char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"octal single digit, extra");
set a \79
puts $a
TCL
\cG9
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"octal double char");
+language_output_is("tcl",<<'TCL',<<OUT,"octal double digit");
set a \12
puts $a
TCL
\cJ
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"octal double char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"octal double digit, extra");
set a \129
puts $a
TCL
\cJ9
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"octal triple char");
+language_output_is("tcl",<<'TCL',<<OUT,"octal triple digit");
set a \123
puts $a
TCL
S
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"octal triple char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"octal triple digit, extra");
set a \1234
puts $a
TCL
S4
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex single char, invalid");
+language_output_is("tcl",<<'TCL',<<OUT,"hex single digit, invalid");
set a \xq
puts $a
TCL
xq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex single char");
+language_output_is("tcl",<<'TCL',<<OUT,"hex single digit");
set a \x7
puts $a
TCL
\cG
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex single char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"hex single digit, extra");
set a \x7q
puts $a
TCL
\cGq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex double char");
+language_output_is("tcl",<<'TCL',<<OUT,"hex double digit");
set a \x6a
puts $a
TCL
j
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex double char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"hex double digit, extra");
set a \x6aq
puts $a
TCL
jq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex triple char, skip ok?");
+language_output_is("tcl",<<'TCL',<<OUT,"hex triple digit, skip ok?");
set a \xb6a
puts $a
TCL
j
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex triple char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"hex triple digit, extra");
set a \xb6aq
puts $a
TCL
jq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex many char");
+language_output_is("tcl",<<'TCL',<<OUT,"hex many digit");
set a \xaaaaaaaaaaab6a
puts $a
TCL
j
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"hex many char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"hex many digit, extra");
set a \xaaaaaaaaaaab6aq
puts $a
TCL
@@ -174,71 +174,74 @@ jq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode single char, invalid");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode single digit, invalid");
set a \uq
puts $a
TCL
uq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode one char");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode one digit");
set a \u7
puts $a
TCL
\cG
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode one char, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode one digit, extra");
set a \u7q
puts $a
TCL
\cGq
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode two chars");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode two digits");
set a \u6a
puts $a
TCL
j
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode two chars, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode two digits, extra");
set a \u6aq
puts $a
TCL
jq
OUT
-TODO: {
+# expected values are in utf8 encoding.
-local $TODO = "These four tests tickle a seg-fault in parrot: [#36794]";
-
-language_output_is("tcl",<<'TCL',<<OUT,"unicode three chars");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode three digits");
set a \u666
puts $a
TCL
-\x{666}
+\xd9\xa6
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode three chars, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode three digits, extra");
set a \u666q
puts $a
TCL
-\x{666}q
+\xd9\xa6q
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode four chars");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode four digits");
set a \u6666
puts $a
TCL
-\x{6666}
+\xe6\x99\xa6
OUT
-language_output_is("tcl",<<'TCL',<<OUT,"unicode four chars, extra");
+language_output_is("tcl",<<'TCL',<<OUT,"unicode four digits, extra");
set a \u6666q
puts $a
TCL
-\x{6666}q
+\xe6\x99\xa6q
OUT
-}
+language_output_is("tcl",<<'TCL',<<OUT,"multiple substs, same word");
+ set a \\\a\007\xaaaa07\u0007\uq
+ puts $a
+TCL
+\\\cG\cG\cG\cGuq
+OUT
