Author: mdiep
Date: Sun Aug 7 21:06:27 2005
New Revision: 8865
Modified:
trunk/languages/tcl/lib/variables.pir
trunk/languages/tcl/t/tcl_var_subst.t
Log:
tcl: Add support for ::x global variables (with tests)
Modified: trunk/languages/tcl/lib/variables.pir
==============================================================================
--- trunk/languages/tcl/lib/variables.pir (original)
+++ trunk/languages/tcl/lib/variables.pir Sun Aug 7 21:06:27 2005
@@ -182,22 +182,25 @@ Gets the actual variable from memory and
.sub __find_var
.param string name
+ name = "$" . name
.local pmc value
null value
+
+ push_eh done
+ $S0 = substr name, 1, 2
+ if $S0 == "::" goto coloned
.local int call_level
$P1 = find_global "_Tcl", "call_level"
call_level = $P1
-
- name = "$" . name
-
- push_eh done
if call_level == 0 goto global_var
lexical_var:
value = find_lex call_level, name
goto found
+coloned:
+ substr name, 1, 2, ""
global_var:
value = find_global "Tcl", name
# goto found
@@ -220,18 +223,21 @@ Sets the actual variable from memory.
.sub __store_var
.param string name
.param pmc value
-
+ name = "$" . name
+
+ $S0 = substr name, 1, 2
+ if $S0 == "::" goto coloned
+
.local int call_level
$P1 = find_global "_Tcl", "call_level"
call_level = $P1
-
- name = "$" . name
-
if call_level == 0 goto global_var
lexical_var:
store_lex call_level, name, value
.return()
+coloned:
+ substr name, 1, 2, ""
global_var:
store_global "Tcl", name, value
Modified: trunk/languages/tcl/t/tcl_var_subst.t
==============================================================================
--- trunk/languages/tcl/t/tcl_var_subst.t (original)
+++ trunk/languages/tcl/t/tcl_var_subst.t Sun Aug 7 21:06:27 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 8;
+use Parrot::Test tests => 10;
use Test::More;
language_output_is("tcl",<<'TCL',<<OUT,"middle");
@@ -60,3 +60,18 @@ language_output_is("tcl",<<'TCL',<<'OUT'
TCL
44
OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"read global");
+ set x foo
+ puts $::x
+TCL
+foo
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"write global");
+ set ::x foo
+ puts $x
+TCL
+foo
+OUT
+
