Unicode escapes now working in tcl (modulo a seg fault in the substr

opcode.)



git-svn-id: https://svn.parrot.org/parrot/trunk@8787 d31e2699-5ff4-0310-a27c-f18f2fbe73fe

languages/tcl/lib/tclconst.pir

@@ -213,10 +213,45 @@ Unicode escapes consist of an C<u>, followed by one to four hexadecimal digits.
 
 =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

languages/tcl/t/tcl_backslash.t

@@ -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