Author: leo
Date: Thu Aug 11 22:46:57 2005
New Revision: 8925
Modified:
branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t
branches/leo-ctx5/languages/m4/t/freezing/001_freeze.t
branches/leo-ctx5/languages/tcl/lib/commands/lindex.pir
branches/leo-ctx5/languages/tcl/lib/expression.pir
branches/leo-ctx5/languages/tcl/lib/parser.pir
branches/leo-ctx5/languages/tcl/t/cmd_list.t
branches/leo-ctx5/languages/tcl/t/tcl_misc.t
branches/leo-ctx5/lib/Parrot/Test/Tcl.pm
Log:
merge -r8916:8924 from trunk
Modified: branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t
==============================================================================
--- branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t (original)
+++ branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t Thu Aug 11
22:46:57 2005
@@ -4,14 +4,17 @@ use strict;
use FindBin;
use lib "$FindBin::Bin/../../lib", "$FindBin::Bin/../../../../lib";
+use Parrot::Config;
use Parrot::Test tests => 1 + 1;
+my $true = "$PConfig{perl} -e exit(0)";
+my $false = "$PConfig{perl} -e exit(1)";
+
SKIP:
{
- skip( "`false' not available on $^O", 1 ) if ($^O =~ /MSWin32/);
skip( "difference between running a process in a fork, or with system()", 1
);
language_output_is( 'm4', <<'CODE', <<'OUT', 'output of "false"' );
-syscmd(`false')
+syscmd(`$false`)
sysval()
CODE
@@ -20,10 +23,8 @@ OUT
}
{
- skip( "`true' not available on $^O", 1 ) if ($^O =~ /MSWin32/);
-
language_output_is( 'm4', <<'CODE', <<'OUT', 'output of "true"' );
-syscmd(`true')
+syscmd(`$true')
sysval()
CODE
Modified: branches/leo-ctx5/languages/m4/t/freezing/001_freeze.t
==============================================================================
--- branches/leo-ctx5/languages/m4/t/freezing/001_freeze.t (original)
+++ branches/leo-ctx5/languages/m4/t/freezing/001_freeze.t Thu Aug 11
22:46:57 2005
@@ -8,10 +8,13 @@ use Parrot::Config;
use Test::More tests => 1;
my $parrot_m4 = "cd .. && .$PConfig{slash_exec}parrot$PConfig{exe}
languages/m4/m4.pbc";
+my $cat = "$PConfig{perl} -MExtUtils::Command -e cat";
+my $rm_f = "$PConfig{perl} -MExtUtils::Command -e rm_f";
+my $real_out = `$parrot_m4
--reload-state=languages/m4/examples/only_builtin.frozen
--freeze-state=languages/m4/examples/hello.frozen
languages/m4/examples/hello.m4`;
+$real_out .= `$cat m4/examples/hello.frozen`;
+$real_out .= `$rm_f m4/examples/hello.frozen`;
-#--------------------------------------------
-my $real_out = `$parrot_m4
--reload-state=languages/m4/examples/only_builtin.frozen
--freeze-state=languages/m4/examples/hello.frozen
languages/m4/examples/hello.m4; cat languages/m4/examples/hello.frozen; rm
languages/m4/examples/hello.frozen`;
is( $real_out, << 'END_OUT', '1 file' );
Hello
T8,8
Modified: branches/leo-ctx5/languages/tcl/lib/commands/lindex.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/lindex.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/lindex.pir Thu Aug 11
22:46:57 2005
@@ -53,9 +53,9 @@ select_loop:
goto select_loop
bad_args:
- return_type = TCL_ERROR
- retval = new TclString
+ retval = new String
retval = "wrong # args: should be \"lindex list ?index...?\""
+ .return (TCL_ERROR, retval)
have_elem:
retval = list
Modified: branches/leo-ctx5/languages/tcl/lib/expression.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/expression.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/expression.pir Thu Aug 11 22:46:57 2005
@@ -20,9 +20,10 @@ however, then we're returning the invoka
.param string expr
.param pmc foo
- .local int return_type # TCL return code
+ .local pmc retval
+ .local int return_type
return_type = TCL_OK
- .local pmc retval # TCL return value
+
.local pmc chunk # the current chunk we're working on
.local pmc ops # Global list of available ops.
ops = find_global "_Tcl", "operators"
@@ -44,7 +45,7 @@ got_arg:
chunk_end = 0
.local int char
.local int expr_length
- length expr_length, expr
+ expr_length = length expr
#print "CALLED WITH "
#print expr
@@ -99,7 +100,7 @@ get_paren_done:
$I0 = $I1 - chunk_start
dec $I0
inc chunk_start
- substr $S1, expr, chunk_start, $I0
+ $S1 = substr expr, chunk_start, $I0
# XXX this is now officially braindead. Fissit.
(return_type,retval) = __expression_parse($S1)
@@ -197,7 +198,7 @@ get_operator:
.local int expr_len
.local string test_op
- length expr_len, expr
+ expr_len = length expr
# cheat - right now there are only 2 and 1 character ops
# 2 char trump one char.
@@ -207,7 +208,7 @@ get_operator:
two_char:
op_len = 2
- substr test_op, expr, chunk_start, op_len
+ test_op = substr expr, chunk_start, op_len
$P11 = ops[test_op]
isnull $P11, one_char
$I1 = typeof $P11
@@ -217,7 +218,7 @@ two_char:
one_char:
op_len = 1
- substr test_op, expr, chunk_start, op_len
+ test_op = substr expr, chunk_start, op_len
$P11 = ops[test_op]
isnull $P11, op_fail
$I1 = typeof $P11
@@ -290,7 +291,7 @@ converter_loop:
if stack_index >= input_len goto precedence_done
our_op = chunks[stack_index]
isnull our_op, converter_next
- typeof $I0, our_op
+ $I0 = typeof our_op
if $I0 == .Undef goto converter_next
$I2 = our_op[0]
if $I2 == INTEGER goto converter_next
@@ -314,7 +315,7 @@ right_arg:
isnull retval, left_arg
chunks[$I2] = undef
inc $I4
- unshift program_stack, retval
+ program_stack = unshift retval
# If we're a function, (XXX) assume a single arg (which
# we've now pulled - so, go to the, skip the left arg.
@@ -329,11 +330,11 @@ left_arg:
isnull retval, shift_op
chunks[$I2] = undef
inc $I4
- unshift program_stack, retval
+ program_stack = unshift retval
shift_op:
#print "shift_op\n"
- unshift program_stack,our_op
+ program_stack = unshift our_op
chunks[stack_index] = undef
converter_next:
@@ -662,7 +663,7 @@ evaluation_return:
.param int start
.local int len
- length len, expr
+ len = length expr
.local int pos
.local int char
.local int flag
@@ -676,7 +677,7 @@ evaluation_return:
first_digit:
# Is the first digit a 0? if so, this is octal or hex.
- ord $I0, expr, pos
+ $I0 = ord expr, pos
if $I0 != 48 goto decimal
#inc pos
#ord $I0, expr, pos
@@ -688,7 +689,7 @@ octal:
inc pos
octal_loop:
if pos>=len goto octal_loop_done
- ord $I0, expr,pos
+ $I0 = ord expr,pos
if $I0 > 55 goto octal_loop_done # ">8"
if $I0 < 48 goto octal_loop_done # "<0
flag = 1
@@ -703,7 +704,7 @@ octal_finish_up:
inc start
dec pos
- substr $S0, expr, start,pos
+ $S0 = substr expr, start, pos
$P1 = new TclList
$P1[0] = $S0
@@ -717,7 +718,7 @@ decimal:
loop:
# cheat
if pos >= len goto loop_done
- ord $I0, expr, pos
+ $I0 = ord expr, pos
if $I0 > 57 goto loop_done # > "9"
if $I0 < 48 goto loop_done # < "0"
flag = 1
@@ -732,7 +733,7 @@ failure:
goto real_done
finish_up:
- substr $S0, expr, start,pos
+ $S0 = substr expr, start, pos
$I0 = $S0
value = new TclList
value[0] = INTEGER
@@ -760,14 +761,14 @@ real_done:
varname = new FixedPMCArray
.local int expr_length
- length expr_length, expr
+ expr_length = length expr
# is this even a variable?
- ord $I0, expr, start
+ $I0 = ord expr, start
if $I0 != 36 goto real_done
inc start
- ord $I0, expr, start
+ $I0 = ord expr, start
if $I0 == 123 goto braced
pos = start
@@ -784,7 +785,7 @@ var_loop:
if pos >= expr_length goto var_loop_done
- ord $I0, expr, pos
+ $I0 = ord expr, pos
if $I0 == 40 goto indexed_var
if $I0 < 48 goto var_loop_done
if $I0 <= 58 goto var_loop_next
@@ -803,7 +804,7 @@ var_loop_done:
$I0 = pos - start
- substr $S0, expr, start, $I0
+ $S0 = substr expr, start, $I0
varname = 1
varname[0] = $S0
goto real_done
@@ -812,7 +813,7 @@ indexed_var:
# just like var_loop_done, mark the name of the var
dec pos
$I0 = pos - start
- substr $S0, expr, start, $I0
+ $S0 = substr expr, start, $I0
varname = 2
varname[0] = $S0
@@ -821,7 +822,7 @@ indexed_var:
index $I1, ")", expr, pos
$I2 = $I1 - pos
- substr $S0, expr, pos, $I2
+ $S0 = substr expr, pos, $I2
varname[1] = $S0
goto real_done
@@ -834,7 +835,7 @@ braced:
pos = $I0
$I1 = $I0 - start
- substr $S0, expr, start, $I1
+ $S0 = substr expr, start, $I1
varname[0] = $S0
@@ -897,12 +898,12 @@ loop_done:
.local int len
len = start_paren_pos - start
- substr $S0, expr, start, len
+ $S0 = substr expr, start, len
$P1 = find_global "_Tcl", "functions"
func = $P1[$S0]
isnull func, fail
- typeof $I0, func
+ $I0 = typeof func
if $I0 == .Undef goto fail
# and the operand is what's between the ()'s - get the result
@@ -915,7 +916,7 @@ loop_done:
.local int len_operand
len_operand = $I1
- substr $S1, expr, start_paren_pos, len_operand
+ $S1 = substr expr, start_paren_pos, len_operand
# XXX should be checking return value here.
($I9,operand) = __expression_parse($S1)
($I9,operand) = __expression_interpret(operand)
Modified: branches/leo-ctx5/languages/tcl/lib/parser.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/parser.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/parser.pir Thu Aug 11 22:46:57 2005
@@ -1,5 +1,27 @@
.namespace [ "_Tcl" ]
+=head1 NAME
+
+Tcl Parser
+
+=head1 DESCRIPTION
+
+This is the parser that makes up the heart of Partcl. It follows
+the 11 rules that are found in the Tcl manpage, available online
+at <http://www.tcl.tk/man/tcl8.4/TclCmd/Tcl.htm>.
+
+=head FUNCTIONS
+
+=over 4
+
+=item C<pmc commands = parse(string tcl_code)>
+
+Parses the Tcl code and returns an array of TclCommand objects.
+First, it performs the \<newline> substitution. Then it fetches
+commands, one at a time (skipping over comments).
+
+=cut
+
.sub parse
.param string tcl_code
@@ -68,6 +90,18 @@ done:
.return(commands)
.end
+=item C<int pos = skip_comment(string tcl_code, int pos)>
+
+Checks for a comment and returns either the original pos
+or the position after the comment.
+
+ Incoming: # comment\n
+ ^
+ Outgoing: # comment\n
+ ^^
+
+=cut
+
.sub skip_comment
.param string tcl_code
.param int pos
@@ -99,6 +133,18 @@ got_comment:
.return (new_pos)
.end
+=item C<(pmc command, int pos) = get_command(string tcl_code, pmc chars, int
pos)>
+
+Tries to get a command from the Tcl code at pos, stopping at the
+first character that's ord value exists in the chars hash.
+
+ Incoming: puts [lindex "a b c" 1]
+ ^
+ Outgoing: puts [lindex "a b c" 1]
+ ^
+
+=cut
+
.sub get_command
.param string tcl_code
.param pmc chars
@@ -134,6 +180,20 @@ done:
.return(command, pos)
.end
+=item C<(pmc word, int pos) = get_word(string tcl_code, pmc chars, int pos)>
+
+Parses a word, starting at pos and ending at the first character
+that's ord value exists in the chars hash. Returns either a TclWord
+object or a TclConst, TclCommand, or TclVar object if the Tclword
+contains only one.
+
+ Incoming: puts foo\n
+ ^
+ Outgoing: puts foo\n
+ ^^
+
+=cut
+
.sub get_word
.param string tcl_code
.param pmc chars
@@ -219,7 +279,8 @@ subcommand2:
($P0, pos) = get_subcommand(tcl_code, pos)
push word, $P0
- start = pos + 1
+ start = pos
+ dec pos
goto loop
have_word:
@@ -242,15 +303,28 @@ done:
dispatch_sub:
$S0 = dispatch[char]
$P0 = find_name $S0
- (word, pos) = $P0(tcl_code, pos)
+ (word, pos) = $P0(tcl_code, chars, pos)
inc pos
really_done:
.return(word, pos)
.end
+=item C<(pmc word, int pos) = get_quote(string tcl_code, pmc chars, int pos)>
+
+Parses a quote and returns a TclWord object containing the separate
+parts (or, if there's only one, it's child).
+
+ Incoming; puts [lindex "a b c" 1]
+ ^
+ Outgoing: puts [lindex "a b c" 1]
+ ^
+
+=cut
+
.sub get_quote
.param string tcl_code
+ .param pmc chars
.param int pos
.local int start
@@ -270,7 +344,7 @@ loop:
if $I0 == 92 goto backslash # \
if $I0 == 36 goto variable # $
if $I0 == 91 goto subcommand # [
- if $I0 == 34 goto done # "
+ if $I0 == 34 goto check_chars # "
goto loop
backslash:
inc pos
@@ -303,7 +377,8 @@ subcommand2:
($P0, pos) = get_subcommand(tcl_code, pos)
push word, $P0
- start = pos + 1
+ start = pos
+ dec pos
goto loop
missing_quote:
@@ -311,6 +386,19 @@ missing_quote:
$P0["_message"] = "missing quote"
throw $P0
+check_chars:
+ $I0 = pos + 1
+ if $I0 == len goto done
+ $I1 = is_whitespace tcl_code, $I0
+ if $I1 == 1 goto done
+ $I1 = ord tcl_code, $I0
+ $I1 = exists chars[$I1]
+ if $I1 == 1 goto done
+
+ $P0 = new Exception
+ $P0["_message"] = "extra characters after close-quote"
+ throw $P0
+
done:
$I0 = pos - start
$S0 = substr tcl_code, start, $I0
@@ -322,8 +410,20 @@ done:
.return(word, pos)
.end
+=item C<(pmc const, int pos) = get_brace(string tcl_code, pmc chars, int pos)>
+
+Parses a {} quoted expression, returning a TclConst object.
+
+ Incoming: puts {foo}
+ ^
+ Outgoing: puts {foo}
+ ^
+
+=cut
+
.sub get_brace
.param string tcl_code
+ .param pmc chars
.param int pos
.local int start, len
@@ -349,7 +449,7 @@ left:
goto loop
right:
dec depth
- if depth == 0 goto done
+ if depth == 0 goto check_chars
goto loop
missing_close_brace:
@@ -357,6 +457,19 @@ missing_close_brace:
$P0["_message"] = "missing close-brace"
throw $P0
+check_chars:
+ $I0 = pos + 1
+ if $I0 == len goto done
+ $I1 = is_whitespace tcl_code, $I0
+ if $I1 == 1 goto done
+ $I1 = ord tcl_code, $I0
+ $I1 = exists chars[$I1]
+ if $I1 == 1 goto done
+
+ $P0 = new Exception
+ $P0["_message"] = "extra characters after close-brace"
+ throw $P0
+
done:
$I0 = pos - start
@@ -372,6 +485,17 @@ done:
.return($P0, pos)
.end
+=item C<(pmc command, int pos) = get_subcommand(string tcl_code, int pos)>
+
+Parses a subcommand and returns a TclCommand object.
+
+ Incoming: puts [lindex "a b c" 1]
+ ^
+ Outgoing: puts [lindex "a b c" 1]
+ ^
+
+=cut
+
.sub get_subcommand
.param string tcl_code
.param int pos
@@ -381,12 +505,21 @@ done:
chars = new Hash
chars[93] = 1 # ]
- ($P0, $I0) = get_command(tcl_code, chars, pos)
- dec $I0
-
- .return($P0, $I0)
+ .return get_command(tcl_code, chars, pos)
.end
+=item C<(pmc var, int pos) = parse_variable(string tcl_code, int pos)>
+
+If it's really a variable, returns a TclVar object. If it's
+something else, return a TclConst object.
+
+ Incoming: puts $foo\n
+ ^
+ Outgoing: puts $foo\n
+ ^^
+
+=cut
+
.sub parse_variable
.param string tcl_code
.param int pos
@@ -410,7 +543,7 @@ char:
if $I0 goto char
$I0 = ord tcl_code, pos
if $I0 == 58 goto colon # :
- if $I0 == 40 goto index #
+ if $I0 == 40 goto index # (
# goto check_length
check_length:
@@ -463,3 +596,7 @@ done:
$P0 = $S0
.return($P0, pos)
.end
+
+=back
+
+=cut
Modified: branches/leo-ctx5/languages/tcl/t/cmd_list.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/cmd_list.t (original)
+++ branches/leo-ctx5/languages/tcl/t/cmd_list.t Thu Aug 11 22:46:57 2005
@@ -2,8 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 16;
-use vars qw($TODO);
+use Parrot::Test tests => 15;
language_output_is("tcl",<<'TCL',<<OUT,"no elements");
puts [list]
@@ -96,11 +95,3 @@ TCL
\]
OUT
-TODO: {
- local $TODO = "need smarter string to list processing.";
-language_output_is("tcl",<<'TCL',<<'OUT',"extra characters after close brace");
- list {a}a
-TCL
-extra characters after close brace
-OUT
-}
Modified: branches/leo-ctx5/languages/tcl/t/tcl_misc.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/tcl_misc.t (original)
+++ branches/leo-ctx5/languages/tcl/t/tcl_misc.t Thu Aug 11 22:46:57 2005
@@ -2,9 +2,8 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 18;
+use Parrot::Test tests => 19;
use Test::More;
-use vars qw($TODO);
language_output_is("tcl",<<'TCL',<<OUT,"leading spacex2 should be ok");
puts Parsing
@@ -124,15 +123,15 @@ TCL
2
OUT
-TODO: {
-local $TODO = "unimplemented";
+language_output_is("tcl",<<'TCL',<<'OUT',"extra characters after close-quote");
+ list "a"a
+TCL
+extra characters after close-quote
+OUT
-language_output_is("tcl",<<'TCL',<<'OUT',"no extra characters after close
quote")
-set a 2
-puts [set "a"a]
-puts 1
+language_output_is("tcl",<<'TCL',<<'OUT',"extra characters after close-brace");
+ list {a}a
TCL
-extra characters after close quote
+extra characters after close-brace
OUT
-}
Modified: branches/leo-ctx5/lib/Parrot/Test/Tcl.pm
==============================================================================
--- branches/leo-ctx5/lib/Parrot/Test/Tcl.pm (original)
+++ branches/leo-ctx5/lib/Parrot/Test/Tcl.pm Thu Aug 11 22:46:57 2005
@@ -44,11 +44,8 @@ sub output_is() {
$cmd = "$self->{parrot} $args languages/tcl/tcl.pbc $lang_f";
- # For some reason, if you redirect both STDERR and STDOUT here,
- # you get a 38M file of garbage. We'll temporarily assume everything
- # works and ignore stderr.
$exit_code = Parrot::Test::run_command($cmd, CD => $self->{relpath},
- STDOUT => $out_f);
+ STDOUT => $out_f, STDERR => $out_f);
unless ($pass) {
my $file = Parrot::Test::slurp_file($out_f);
