Author: coke
Date: Wed Aug 17 08:45:44 2005
New Revision: 8977
Modified:
trunk/languages/tcl/lib/commands/namespace.pir
trunk/languages/tcl/t/cmd_namespace.t
Log:
[tcl] finish [namespace tail] and [namespace qualifiers]
Modified: trunk/languages/tcl/lib/commands/namespace.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/namespace.pir (original)
+++ trunk/languages/tcl/lib/commands/namespace.pir Wed Aug 17 08:45:44 2005
@@ -107,8 +107,32 @@ bad_args:
.param pmc argv
.local int argc
+ argc = argv
if argc != 1 goto bad_args
+ .local pmc p6r,match
+ p6r = find_global "PGE", "p6rule"
+ match = p6r("(.*)\:\:+<-[:]>*$$")
+
+ $S0 = argv[0]
+ $P0 = match($S0)
+ unless $P0 goto WHOLE
+
+ # XXX pre leo-ctx5 this requires a PMC arg, but we can switch later
+ $P1 = new String
+ $P1 = "0"
+
+ $P2 = $P0."__get_pmc_keyed"($P1)
+
+ $S1 = $P2
+ $P3 = new String
+ $P3 = $S1
+ .return (TCL_OK,$P3)
+
+WHOLE:
+ $P0 = argv[0]
+ .return(TCL_OK,$P0)
+
bad_args:
$P1 = new String
$P1 = "wrong # args: should be \"namespace qualifiers string\""
@@ -120,12 +144,35 @@ bad_args:
.param pmc argv
.local int argc
+ argc = argv
if argc != 1 goto bad_args
+ .local pmc p6r,match
+ p6r = find_global "PGE", "p6rule"
+ match = p6r("\:\:+(<-[:]>)$$")
+
+ $S0 = argv[0]
+ $P0 = match($S0)
+ unless $P0 goto WHOLE
+
+ # XXX pre leo-ctx5 this requires a PMC arg, but we can switch later
+ $P1 = new String
+ $P1 = "0"
+
+ $P2 = $P0."__get_pmc_keyed"($P1)
+
+ $S1 = $P2
+ $P3 = new String
+ $P3 = $S1
+ .return (TCL_OK,$P3)
+
+WHOLE:
+ $P0 = argv[0]
+ .return(TCL_OK,$P0)
+
bad_args:
$P1 = new String
$P1 = "wrong # args: should be \"namespace tail string\""
.return (TCL_ERROR,$P1)
.end
-
Modified: trunk/languages/tcl/t/cmd_namespace.t
==============================================================================
--- trunk/languages/tcl/t/cmd_namespace.t (original)
+++ trunk/languages/tcl/t/cmd_namespace.t Wed Aug 17 08:45:44 2005
@@ -30,8 +30,6 @@ TCL
wrong # args: should be "namespace qualifiers string"
OUT
-TODO: {
- local $TODO = "unimplemented";
language_output_is("tcl",<<'TCL',<<OUT,"namespace qualifiers: simple");
puts [namespace qualifiers ::a::b::c]
TCL
@@ -41,9 +39,8 @@ OUT
language_output_is("tcl",<<'TCL',<<OUT,"namespace qualifiers: extra colons");
puts [namespace qualifiers :::a:::b::c]
TCL
-::a::b
+:::a:::b
OUT
-}
language_output_is("tcl",<<'TCL',<<OUT,"namespace tail: no args");
namespace tail
@@ -57,8 +54,6 @@ TCL
wrong # args: should be "namespace tail string"
OUT
-TODO: {
- local $TODO = "unimplemented";
language_output_is("tcl",<<'TCL',<<OUT,"namespace tail: simple");
puts [namespace tail ::a::b::c]
TCL
@@ -70,7 +65,6 @@ language_output_is("tcl",<<'TCL',<<OUT,"
TCL
c
OUT
-}
language_output_is("tcl",<<'TCL',<<OUT,"namespace current: too many args");
namespace current current
