Author: leo
Date: Thu Aug 18 03:10:32 2005
New Revision: 8983
Added:
branches/leo-ctx5/languages/tcl/lib/commands/gets.pir
- copied unchanged from r8982, trunk/languages/tcl/lib/commands/gets.pir
Modified:
branches/leo-ctx5/MANIFEST
branches/leo-ctx5/config/gen/makefiles/tcl.in
branches/leo-ctx5/languages/tcl/docs/hacks.pod
branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir
branches/leo-ctx5/languages/tcl/lib/commands/open.pir
branches/leo-ctx5/languages/tcl/t/cmd_namespace.t
branches/leo-ctx5/src/library.c
Log:
merge -r8975:8982 from trunk
Modified: branches/leo-ctx5/MANIFEST
==============================================================================
--- branches/leo-ctx5/MANIFEST (original)
+++ branches/leo-ctx5/MANIFEST Thu Aug 18 03:10:32 2005
@@ -1386,6 +1386,7 @@ languages/tcl/lib/commands/expr.pir
languages/tcl/lib/commands/for.pir [tcl]
languages/tcl/lib/commands/foreach.pir [tcl]
languages/tcl/lib/commands/format.pir [tcl]
+languages/tcl/lib/commands/gets.pir [tcl]
languages/tcl/lib/commands/global.pir [tcl]
languages/tcl/lib/commands/if.pir [tcl]
languages/tcl/lib/commands/join.pir [tcl]
Modified: branches/leo-ctx5/config/gen/makefiles/tcl.in
==============================================================================
--- branches/leo-ctx5/config/gen/makefiles/tcl.in (original)
+++ branches/leo-ctx5/config/gen/makefiles/tcl.in Thu Aug 18 03:10:32 2005
@@ -30,6 +30,7 @@ lib${slash}commands${slash}expr.pir \
lib${slash}commands${slash}for.pir \
lib${slash}commands${slash}foreach.pir \
lib${slash}commands${slash}format.pir \
+lib${slash}commands${slash}gets.pir \
lib${slash}commands${slash}global.pir \
lib${slash}commands${slash}if.pir \
lib${slash}commands${slash}incr.pir \
Modified: branches/leo-ctx5/languages/tcl/docs/hacks.pod
==============================================================================
--- branches/leo-ctx5/languages/tcl/docs/hacks.pod (original)
+++ branches/leo-ctx5/languages/tcl/docs/hacks.pod Thu Aug 18 03:10:32 2005
@@ -66,7 +66,7 @@ be nice to have invoke() automatically f
that Tcl can use. (This also starts to drag in "how to do Tcl exceptions
cleanly from
parrot")
-=head1 [error], [catch], [break], continue...
+=item [error], [catch], [break], continue...
Tcl kind of conflates normal returns and exceptional returns, and uses the same
mechanism for [break]ing and [continue]'ing out of loops.
@@ -89,12 +89,12 @@ mechanism. So we could potentially use e
term. But then [catch] will need to be re-written to cope with exceptions
or not (as opposed to now, where all codes are equal).
-=head1 stack depth
+=item stack depth
-Cheating and keeping a global around right now, so we can figure out if we
should
-be using a global or a lexical (and if so, how far down or up).
+Cheating and keeping a global around right now, so we can figure out if we
+should be using a global or a lexical (and if so, how far down or up).
-=head1 [trace]'ing
+=item [trace]'ing
There are two ways we can go about the tracing - either we can keep the
information about the traces in a global, and check that global every time
@@ -103,7 +103,8 @@ actual commands and variables. I think t
and, if any other languages support this feature, this would give us a chance
to interoperate.
-=cut
+=back
+=cut
Modified: branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir Thu Aug 18
03:10:32 2005
@@ -108,8 +108,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\""
@@ -121,12 +145,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: branches/leo-ctx5/languages/tcl/lib/commands/open.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/open.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/open.pir Thu Aug 18
03:10:32 2005
@@ -1,50 +1,44 @@
-###
-# [open]
-
-# XXX These variants of open are not supported.
-# open filename access
-# open filename access permissions
-
.namespace [ "Tcl" ]
.sub "open"
.param pmc argv :slurpy
.local int return_type
- .local pmc retval
+ .local pmc retval,channel,next_channel_id,channels
+ .local string channel_id
+
retval = new String
.local int argc
argc = argv
if argc != 1 goto error
- $S1 = argv[0]
- open $P1, $S1, ">"
- $I0 = typeof $P1
+ channel_id = argv[0]
+ open channel, channel_id, "<"
+ $I0 = typeof channel
if $I0 == .Undef goto file_error
- retval = "file"
- $P2 = find_global "_Tcl", "channels"
+ channel_id = "file"
+ channels = find_global "_Tcl", "channels"
# get a new file channel name
- $P3 = find_global "_Tcl", "next_channel_id"
- $S0 = $P3
- retval = retval . $S0
- $P3 = $P3 + 1
- $P2[retval] = $P1
- #print "retval is:"
- #print retval
- #print "\n"
+ next_channel_id = find_global "_Tcl", "next_channel_id"
+ $S0 = next_channel_id
+ channel_id .= $S0
+ next_channel_id += 1
+ channels[channel_id] = channel
goto done
file_error:
- return_type = TCL_ERROR
+ retval = new String
retval = "unable to open specified file"
- goto done
+ .return(TCL_ERROR,retval)
error:
- return_type = TCL_ERROR
+ retval = new String
retval = "bad call to open"
- goto done
+ .return(TCL_ERROR,retval)
done:
+ retval = new String
+ retval = channel_id
.return(return_type,retval)
.end
Modified: branches/leo-ctx5/languages/tcl/t/cmd_namespace.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/cmd_namespace.t (original)
+++ branches/leo-ctx5/languages/tcl/t/cmd_namespace.t Thu Aug 18 03:10:32 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
Modified: branches/leo-ctx5/src/library.c
==============================================================================
--- branches/leo-ctx5/src/library.c (original)
+++ branches/leo-ctx5/src/library.c Thu Aug 18 03:10:32 2005
@@ -212,9 +212,11 @@ Parrot_locate_runtime_file(Interp *inter
* if the extension is given use it
* TODO if not try extensions according to type
*/
+ /* let the failure propagate back for better error handling
if (!ext) {
internal_exception(UNIMPLEMENTED, "no extension: file '%s'",
file_name);
}
+ */
/* use absolute paths as is */
#ifdef WIN32
