[svn:parrot] r10777 - in trunk/languages/tcl: lib lib/builtins t

[mdiep]

Author: mdiep
Date: Thu Dec 29 12:32:29 2005
New Revision: 10777

Modified:
   trunk/languages/tcl/lib/builtins/incr.pir
   trunk/languages/tcl/lib/conversions.pir
   trunk/languages/tcl/t/cmd_incr.t
Log:
tcl: [incr] expects integers, not just any number

Modified: trunk/languages/tcl/lib/builtins/incr.pir
==============================================================================
--- trunk/languages/tcl/lib/builtins/incr.pir   (original)
+++ trunk/languages/tcl/lib/builtins/incr.pir   Thu Dec 29 12:32:29 2005
@@ -27,9 +27,9 @@
   register_num = value_num + 1
 
   pir_code .= <<"END_PIR"
-.local pmc read, set, number
+.local pmc read, set, integer
 read = find_global '_Tcl', '__read'
-number = find_global '_Tcl', '__number'
+integer = find_global '_Tcl', '__integer'
 set = find_global '_Tcl', '__set'
 END_PIR
 
@@ -42,7 +42,7 @@ END_PIR
   pir_code .= ")\n$P"
   $S0 = register_num
   pir_code .= $S0
-  pir_code .= "=number($P"
+  pir_code .= "=integer($P"
   pir_code .= $S0
   pir_code .= ")\n"
 
@@ -70,9 +70,9 @@ got_increment:
   register_num = value_num + 1
 
   pir_code .= <<"END_PIR"
-.local pmc read, set, number
+.local pmc read, set, integer
 read = find_global '_Tcl', '__read'
-number = find_global '_Tcl', '__number'
+integer = find_global '_Tcl', '__integer'
 set = find_global '_Tcl', '__set'
 END_PIR
 
@@ -85,12 +85,12 @@ END_PIR
   pir_code .= ")\n$P"
   $S0 = register_num
   pir_code .= $S0
-  pir_code .= "=number($P"
+  pir_code .= "=integer($P"
   pir_code .= $S0
   pir_code .= ")\n$P"
   $S0 = increment_num
   pir_code .= $S0
-  pir_code .= "=number($P"
+  pir_code .= "=integer($P"
   pir_code .= $S0
   pir_code .= ")\n"
 

Modified: trunk/languages/tcl/lib/conversions.pir
==============================================================================
--- trunk/languages/tcl/lib/conversions.pir     (original)
+++ trunk/languages/tcl/lib/conversions.pir     Thu Dec 29 12:32:29 2005
@@ -49,6 +49,7 @@ positive:
   $S0 = substr $S0, 1
   # we check for the length below
   dec $I0
+
 get_value:
   (value, $I1) = get_number($S0, 0)
   if null value goto NaN
@@ -61,3 +62,30 @@ done:
 NaN:
   .throw("Not a number!")
 .end
+
+=head2 _Tcl::__integer
+
+Given a PMC, get an integer from it.
+
+=cut
+
+.sub __integer
+  .param pmc value
+
+  push_eh not_integer
+    value = __number(value)
+  clear_eh
+  $I0 = typeof value
+  if $I0 != .TclInt goto not_integer
+
+  .return(value)
+
+not_integer:
+  $S1 = value
+  $S0 = 'expected integer but got "'
+  $S0 .= $S1
+  $S0 .= '"'
+  .throw($S0)
+.end
+
+

Modified: trunk/languages/tcl/t/cmd_incr.t
==============================================================================
--- trunk/languages/tcl/t/cmd_incr.t    (original)
+++ trunk/languages/tcl/t/cmd_incr.t    Thu Dec 29 12:32:29 2005
@@ -2,7 +2,7 @@
 
 use strict;
 use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 7;
+use Parrot::Test tests => 9;
 use Test::More;
 
 language_output_is("tcl",<<'TCL',<<OUT,"simple");
@@ -60,3 +60,18 @@ language_output_is("tcl",<<'TCL',<<OUT,"
 TCL
 wrong # args: should be "incr varName ?increment?"
 OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"expected integer, got alpha");
+  set a 1
+  incr a a
+TCL
+expected integer but got "a"
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"expected integer, got float");
+  set a 1
+  incr a 1.5
+TCL
+expected integer but got "1.5"
+OUT
+