Author: coke
Date: Tue Jan 10 08:22:21 2006
New Revision: 11041
Added:
trunk/languages/tcl/lib/builtins/time.tmt
Removed:
trunk/languages/tcl/lib/commands/time.pir
Modified:
trunk/MANIFEST
trunk/languages/tcl/config/root.in
trunk/languages/tcl/t/cmd_time.t
trunk/languages/tcl/tools/gen_inline.pl
Log:
tcl -
o convert [time] from interpreted to templated inline.
o add more tests
o make time more feature-complete (int arg checking, etc.: free with
templating)
o expose a bug with tclcommand's compile method, but merely avoid it for now.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Tue Jan 10 08:22:21 2006
@@ -1254,6 +1254,7 @@ languages/tcl/lib/builtins/package.pir
languages/tcl/lib/builtins/pwd.tmt [tcl]
languages/tcl/lib/builtins/regsub.pir [tcl]
languages/tcl/lib/builtins/return.pir [tcl]
+languages/tcl/lib/builtins/time.tmt [tcl]
languages/tcl/lib/builtins/trace.pir [tcl]
languages/tcl/lib/builtins/variable.pir [tcl]
languages/tcl/lib/builtins/while.pir [tcl]
@@ -1294,7 +1295,6 @@ languages/tcl/lib/commands/source.pir
languages/tcl/lib/commands/split.pir [tcl]
languages/tcl/lib/commands/string.pir [tcl]
languages/tcl/lib/commands/switch.pir [tcl]
-languages/tcl/lib/commands/time.pir [tcl]
languages/tcl/lib/commands/unknown.pir [tcl]
languages/tcl/lib/commands/unset.pir [tcl]
languages/tcl/lib/commands/uplevel.pir [tcl]
Modified: trunk/languages/tcl/config/root.in
==============================================================================
--- trunk/languages/tcl/config/root.in (original)
+++ trunk/languages/tcl/config/root.in Tue Jan 10 08:22:21 2006
@@ -25,7 +25,8 @@ GENERATED_INLINES = \
$(BUILTIN)${slash}incr.pir \
$(BUILTIN)${slash}join.pir \
$(BUILTIN)${slash}llength.pir \
- $(BUILTIN)${slash}pwd.pir
+ $(BUILTIN)${slash}pwd.pir \
+ $(BUILTIN)${slash}time.pir
DEPS = \
lib${slash}commands${slash}after.pir \
@@ -81,7 +82,6 @@ lib${slash}commands${slash}source.pir \
lib${slash}commands${slash}split.pir \
lib${slash}commands${slash}string.pir \
lib${slash}commands${slash}switch.pir \
-lib${slash}commands${slash}time.pir \
lib${slash}builtins${slash}trace.pir \
lib${slash}commands${slash}unknown.pir \
lib${slash}commands${slash}unset.pir \
Added: trunk/languages/tcl/lib/builtins/time.tmt
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/builtins/time.tmt Tue Jan 10 08:22:21 2006
@@ -0,0 +1,24 @@
+{
+ command => 'time',
+ usage=> "script:script ?count:int=1?",
+ code => <<'END_PIR',
+$I0 = $P{register_count}
+time_loop_{register_num}:
+if $I0 == 0 goto time_{register_num}_done
+$N0 = time
+{register_script_code}
+dec $I0
+goto time_loop_{register_num}
+time_{register_num}_done:
+$N{register_num} = time
+$N{register_num} = $N{register_num} - $N0
+$N{register_num} = $N{register_num} * 1000000
+$N0 = $P{register_count}
+$N{register_num} = $N{register_num} / $N0
+$I{register_num} = $N{register_num}
+$S{register_num} = $I{register_num}
+$S{register_num} .= ' microseconds per iteration'
+$P{register_num} = new .TclString
+$P{register_num} = $S{register_num}
+END_PIR
+}
Modified: trunk/languages/tcl/t/cmd_time.t
==============================================================================
--- trunk/languages/tcl/t/cmd_time.t (original)
+++ trunk/languages/tcl/t/cmd_time.t Tue Jan 10 08:22:21 2006
@@ -2,8 +2,34 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 1;
+use Parrot::Test tests => 5;
-language_output_like('tcl', <<'TCL', '/\d+ microseconds per iteration\n/',
'simple time');
+language_output_is(tcl => << 'TCL', <<OUT, "time, not enough args");
+ time
+TCL
+wrong # args: should be "time script ?count?"
+OUT
+
+language_output_is(tcl => << 'TCL', <<OUT, "time, too many args");
+ time a b c
+TCL
+wrong # args: should be "time script ?count?"
+OUT
+
+language_output_is(tcl => << 'TCL', <<OUT, "time bad count arg");
+ time {set a} 3.2
+TCL
+expected integer but got "3.2"
+OUT
+
+language_output_like(tcl => <<'TCL', '/\d+ microseconds per iteration\n/',
'check return value');
puts [time { expr 2+2 }]
TCL
+
+language_output_is(tcl => << 'TCL', <<OUT, "time verify code executed");
+ time {set a 2} 3
+ puts $a
+TCL
+2
+OUT
+
Modified: trunk/languages/tcl/tools/gen_inline.pl
==============================================================================
--- trunk/languages/tcl/tools/gen_inline.pl (original)
+++ trunk/languages/tcl/tools/gen_inline.pl Tue Jan 10 08:22:21 2006
@@ -132,10 +132,10 @@ add_inlined(<<END_PIR);
__list = find_global '_Tcl', '__list'
.local pmc __channel
__channel = find_global '_Tcl', '__channel'
+END_PIR
+add_wrapped(<<END_PIR);
.local pmc __script_compile
__script_compile = find_global '_Tcl', 'compile'
- .local pmc __pir_compile
- __pir_compile = find_global '_Tcl', 'pir_compiler'
END_PIR
# Now, grab each arg off the list and compile it, handling defaults, etc.
@@ -153,16 +153,16 @@ foreach my $arg (@args_opts) {
script => {
pre => sub {
add_wrapped(<<END_PIR);
- ($arg_register,temp_code) = compiler(register_num, $argument)
- register_num = $arg_register + 1
+ .local string ${arg_register}_code
+ ($arg_register,${arg_register}_code) = __script_compile(register_num,
$argument)
+ #XXX This wild increase in register numbers is to avoid a problem in
+ # tcl command's compiler which, in one case, used \$P5 to calculate an
+ # argument, but then returned the result in \$P4. Register usage should be
+ # bounded between the value you pass in and the value you return. Using
+ # something outside that range is bad, mmkay? -coke
+ register_num = $arg_register + 100
END_PIR
},
- post => sub {
- add_inlined(<<END_PIR);
- (\$I{$arg_register},\$P{$arg_register}) =
__script_compile(\$P{${arg_register}})
- (\$P{$arg_register}) = __pir_compile(\$I{$arg_register},\$P{${arg_register}})
-END_PIR
- }
},
var => {
pre => sub {
@@ -177,6 +177,7 @@ END_PIR
$arg_register = ${arg_register}_varname + 1
register_num = $arg_register + 1
END_PIR
+ add_var('temp_code');
},
post => sub {
add_inlined(<<END_PIR);
@@ -190,6 +191,7 @@ END_PIR
($arg_register,temp_code) = compiler(register_num, $argument)
register_num = $arg_register + 1
END_PIR
+ add_var('temp_code');
},
post => sub {
add_inlined(<<END_PIR);
@@ -203,6 +205,7 @@ END_PIR
($arg_register,temp_code) = compiler(register_num, $argument)
register_num = $arg_register + 1
END_PIR
+ add_var('temp_code');
},
post => sub {
add_inlined(<<END_PIR);
@@ -218,6 +221,7 @@ END_PIR
($arg_register,temp_code) = compiler(register_num, $argument)
register_num = $arg_register + 1
END_PIR
+ add_var('temp_code');
},
post => sub {
add_inlined(<<END_PIR);
@@ -231,10 +235,8 @@ END_PIR
($arg_register,temp_code) = compiler(register_num, $argument)
register_num = $arg_register + 1
END_PIR
+ add_var('temp_code');
},
- post => sub {
- add_var('temp_code');
- }
}
};
@@ -258,10 +260,7 @@ END_PIR
my $pre = $type_handlers->{ $arg->{type} }->{pre};
my $post = $type_handlers->{ $arg->{type} }->{post};
- if ($pre) {
- $pre->();
- add_var('temp_code');
- }
+ if ($pre) { $pre->() }
if ($post) { $post->() }
add_wrapped(<<END_PIR);
@@ -335,7 +334,10 @@ foreach my $chunk (@pir_code) {
$line =~ s/"/\\"/g;
$line =~ s/\\n/\\\\n/g;
if ( $line =~ s/(.*?){(.*?)}// ) {
- print " pir_code .= \"$1\"\n";
+ # register interpolation
+ if ($1 ne "") {
+ print " pir_code .= \"$1\"\n";
+ }
print " \$S0 = $2\n";
print " pir_code .= \$S0\n";
redo
