Author: coke
Date: Wed Aug 3 11:46:04 2005
New Revision: 8787
Modified:
trunk/languages/tcl/lib/tclconst.pir
trunk/languages/tcl/t/tcl_backslash.t
Log:
Unicode escapes now working in tcl (modulo a seg fault in the substr
opcode.)
Modified: trunk/languages/tcl/lib/tclconst.pir
==============================================================================
--- trunk/languages/tcl/lib/tclconst.pir (original)
+++ trunk/languages/tcl/lib/tclconst.pir Wed Aug 3 11:46:04 2005
@@ -213,10 +213,45 @@ Unicode escapes consist of an C<u>, foll
=cut
+ .local int uni_pos, uni_digit, uni_value, uni_digit_count
unicode:
- inc pos
+ # at this point, pos is set to the backslash
+ uni_value = 0
+ uni_digit_count = 0
+ uni_pos = pos + 2 # skip the backslash and the u
+
+uni_loop:
+ if uni_digit_count == 4 goto uni_done #only four digits allowed
+ if uni_pos >= value_length goto uni_done
+ $I0 = ord value, uni_pos
+ $I1 = exists hexadecimal[$I0]
+ unless $I1 goto uni_done
+ uni_digit = hexadecimal[$I0]
+ uni_value *= 16 # low byte promoted
+ uni_value += uni_digit # new low byte added.
+
+ inc uni_pos
+ inc uni_digit_count
+
+ goto uni_loop
+
+uni_done:
+ $I0 = uni_pos - pos
+ if $I0 == 2 goto uni_not_really
+ $S0 = chr uni_value
+ substr value, pos, $I0, $S0
+
+ pos = uni_pos
goto loop
+uni_not_really:
+ # This was a \x escape that had no uni value..
+ substr value, pos, 2, "u"
+ pos = uni_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 Wed Aug 3 11:46:04 2005
@@ -4,7 +4,6 @@ use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
use Parrot::Test tests => 34;
use Test::More;
-use vars qw($TODO);
my($tcl,$expected);
@@ -174,16 +173,12 @@ TCL
jq
OUT
-TODO: {
-local $TODO = "unicode escapes recently un-implemented. Fix soon.";
-
-# XXX Should suppress warnings about wide characters in Test::*... how?
language_output_is("tcl",<<'TCL',<<OUT,"unicode single char, invalid");
set a \uq
puts $a
TCL
-xq
+uq
OUT
language_output_is("tcl",<<'TCL',<<OUT,"unicode one char");
@@ -214,6 +209,13 @@ TCL
jq
OUT
+# XXX Should suppress warnings about wide characters in Test::*... how?
+binmode *STDOUT, ':utf8';
+
+TODO: {
+
+local $TODO = "These four tests tickle a seg-fault in parrot";
+
language_output_is("tcl",<<'TCL',<<OUT,"unicode three chars");
set a \u666
puts $a
