cvsuser 04/09/18 23:56:51
Modified: languages/tcl TODO
languages/tcl/lib interpret.imc tcllib.imc
languages/tcl/lib/commands proc.imc rename.imc
lib/Parrot/Test Tcl.pm
Log:
Updates to get Tcl passing all tests again
Revision Changes Path
1.8 +2 -8 parrot/languages/tcl/TODO
Index: TODO
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/TODO,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- TODO 29 May 2004 00:54:44 -0000 1.7
+++ TODO 19 Sep 2004 06:56:48 -0000 1.8
@@ -1,5 +1,7 @@
=head1 TODO
+If only I had an RT queue for these! ^_^
+
=over 4
=item builtins
@@ -7,12 +9,6 @@
for any of the builtins that take a fixed number of ops, remove the
call to C<foldup> and simply define the C<.params>
-=item rename
-
-jens doesn't think we can delete a global
-but we could replace it with
-a null PMC, and have that be a check before any function call.
-
=item given freeze/thaw for objects...
Once freeze/thaw is working for tclwords (currently waiting on parrot
@@ -50,8 +46,6 @@
doesn't handle varargs.
-throw a tcl error if the user-defined proc is called with the wrong # args
-
support default values (e.g.: proc joe {{drink coffee}} { slurp $drink } )
=item compiler vs. interpreter
1.4 +18 -1 parrot/languages/tcl/lib/interpret.imc
Index: interpret.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/interpret.imc,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- interpret.imc 29 May 2004 00:28:48 -0000 1.3
+++ interpret.imc 19 Sep 2004 06:56:49 -0000 1.4
@@ -39,7 +39,7 @@
inc command_num
if command_num == num_commands goto done
if return_type != TCL_OK goto done
-
+ #print "not done\n"
command = commands[command_num]
# this should stringify the tclword object, which performs
@@ -59,6 +59,8 @@
# XXX Originally, we constructed a PerlArray to pass it to the command.
# instead, we now dynamically generate a call to the sub (the only way
# to use a dynamic # of arguments to a function, SFAIK.
+ # For most compilers, this isn't a big deal, since they're not written
+ # IN pir. For our PIR-based interpreter, however, it's kind of kludgey.
# XXX It appears that for the PIR compiler, we can only define .sub's
# This means that we'll need to write the text for a sub that will return
@@ -71,6 +73,7 @@
# as we move towards the tcl compiler, so perhaps we can not worry about it)
#The sub we'll use to drive the calls to the foldup'd subs.
+ # XXX We should NOT be reusing the same sub over and over.
.local string caller_sub_text
.local Exception_Handler ignore
newsub ignore, .Exception_Handler, __default_handler
@@ -129,15 +132,29 @@
$P1 = compile pir_compiler, caller_sub_text
$P2 = find_global "_Tcl", "_driver"
(return_type,retval) = $P2(args)
+ #print "interpret: got return type "
+ #print return_type
+ #print ", got retval "
+ #print retval
+ #print "\n"
goto end_scope
no_command:
return_type = TCL_ERROR
retval = "invalid command name \""
+ # Right now, $S0 begins with a _, remove it.
+ $S0 = substr 0, 1, ""
retval = retval . $S0
retval = retval . "\"\n"
done:
+ # If we've gotten here, and someone returned a TCL_RETURN, we've
+ # already skipped the remaining commands. So, convert it to a TCL_OK
+ # so that it stops propagating outward.
+ if return_type != TCL_RETURN goto done_done
+ return_type = TCL_OK
+
+done_done:
.pcc_begin_return
.return return_type
.return retval
1.2 +1 -2 parrot/languages/tcl/lib/tcllib.imc
Index: tcllib.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/tcllib.imc,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- tcllib.imc 29 May 2004 00:09:09 -0000 1.1
+++ tcllib.imc 19 Sep 2004 06:56:49 -0000 1.2
@@ -150,8 +150,6 @@
# XXX These go away when [proc] is a little smarter.
$P1 = new PerlHash
store_global "_Tcl", "proc_body", $P1
- $P1 = new PerlHash
- store_global "_Tcl", "proc_args", $P1
# Global variable initialization
# XXX Are outer level tcl scopes true globals, or are they merely top
@@ -196,6 +194,7 @@
pir_compiler = compreg "PIR"
# should generate a new sub each time, or no?
+ # yes, we should.
pir_code = ".namespace [ \"_Tcl\" ]\n.sub _throwaway_sub\n.local string
code\ncode = \""
tcl_code = escaper(tcl_code,"\"")
pir_code .= tcl_code
1.4 +42 -34 parrot/languages/tcl/lib/commands/proc.imc
Index: proc.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/proc.imc,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- proc.imc 29 May 2004 00:07:26 -0000 1.3
+++ proc.imc 19 Sep 2004 06:56:50 -0000 1.4
@@ -33,7 +33,6 @@
args = argv[1]
body = argv[2]
-
.local pmc arg_list
arg_list = string2list(args)
@@ -46,15 +45,11 @@
# definition. The arg list will be used to generate the proc's
# indvidual argument handling code.
- # XXX BUG - this version doesn't currently set the args at all,
- # so only procs that take no args work.
-
# Now, shove the parsed routine into the global hash...
$P0 = find_global "_Tcl", "proc_body"
- $P2 = find_global "_Tcl", "proc_args"
$P0[name] = parsed_body
- $P2[name] = arg_list
+ #$P2[name] = arg_list
.local pmc escaper
escaper = find_global "Data::Escape";, "String"
@@ -64,25 +59,49 @@
.local string proc_body
proc_body = ".namespace [\"Tcl\"]\n.sub _"
proc_body .= name
- proc_body .= "\n.param pmc args\n.local pmc interpret\ninterpret = find_global
\"_Tcl\", \"__interpret\"\n.local pmc proc_body\n.local pmc proc_body\n.local pmc
proc_args\n$P0 = find_global \"_Tcl\", \"proc_body\"\n$P1=find_global \"_Tcl\",
\"proc_args\"\nproc_body=$P0[\""
- proc_body .= esc_name
- proc_body .= "\"]\nproc_args = $P1[\""
+ proc_body .= "\n.param pmc args\nargs = foldup\nnew_pad 1\n"
+ .local int arg_count
+ arg_count = arg_list
+ .local int ii
+ ii = 0
+arg_loop:
+ if ii == arg_count goto arg_loop_done
+ $S1 = ii
+ proc_body .= "$P1 = args["
+ proc_body .= $S1
+ proc_body .= "]\nstore_lex -1,\""
+ # XXX This should be Escape'd
+ $S1 = arg_list[ii]
+ proc_body .= $S1
+ proc_body .= "\", $P1\n"
+ ii = ii + 1
+ goto arg_loop
+arg_loop_done:
+
+ proc_body .= ".local pmc interpret\ninterpret = find_global \"_Tcl\",
\"__interpret\"\n.local pmc proc_body\n$P0 = find_global \"_Tcl\",
\"proc_body\"\nproc_body=$P0[\""
proc_body .= esc_name
proc_body .= "\"]\n"
- proc_body .= "#validate arg count\n"
-#.local int passed_arg_num
-#.local int count_arg_num
-#passed_arg_num = args
-#count_arg_num = proc_args
-#if passed_arg_num == count_arg_num goto args_ok
-#
-#args_ok:
+ # I3 is "The number of parameters in PMC registers."
+ proc_body .= "if I3 == "
+ $S1 = arg_count
+ proc_body .= $S1
+ proc_body .= " goto args_ok\n"
+ proc_body .= "bad_args:\n"
+ proc_body .= ".pcc_begin_return\n"
+ proc_body .= ".return 1\n"
+ proc_body .= ".return \"wrong # args: should be \\\""
+ proc_body .= name
+ proc_body .= " "
+ proc_body .= args
+ proc_body .= "\\\"\"\n"
+ proc_body .= ".pcc_end_return\n"
+ proc_body .= "args_ok:\n"
#proc_body .= "#setup vars\n"
- # XXX Is the pop_pad necessary, or is it handled as a side effect of the
- # .pcc_return?
+ # XXX Is the pop_pad necessary, or would it be handled as a side
+ # effect of the .pcc_return?
- proc_body .= "new_pad 1\n($I0,$S0) =
interpret(proc_body)\npop_pad\n.pcc_begin_return\n.return $I0\n.return
$S0\n.pcc_end_return\n.end\n"
+ proc_body .= "($I0,$S0) =
interpret(proc_body)\npop_pad\n.pcc_begin_return\n.return $I0\n.return
$S0\n.pcc_end_return\n.end\n"
# print "PROC_BODY=\n"
# print proc_body
@@ -92,7 +111,6 @@
pir_compiler = compreg "PIR"
$P0 = compile pir_compiler, proc_body
-
goto done
error:
@@ -105,13 +123,3 @@
.return retval
.pcc_end_return
.end
-
-=pod
-
-Here's what the generated sub needs to look like (based on what used to
-be in interpreter...) (GOAL here is to remove all the code in interpreter
-that's specific to UDFS - Calling a UDF should be just like calling a
-real sub.
-
-
-=cut
1.6 +12 -8 parrot/languages/tcl/lib/commands/rename.imc
Index: rename.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/rename.imc,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- rename.imc 29 May 2004 00:07:26 -0000 1.5
+++ rename.imc 19 Sep 2004 06:56:50 -0000 1.6
@@ -23,23 +23,27 @@
oldName = argv[0]
newName = argv[1]
- find_global commands, "commands"
+ oldName = "_" . oldName
+ newName = "_" . newName
- $P1 = commands[oldName]
+ .local pmc theSub
+ # If oldname is just _, then just delete
length $I1, newName
- if $I1 == 0 goto delete
+ if $I1 == 1 goto delete
add:
- commands[newName] = $P1
+ # Grab the original sub
+ theSub = find_global "Tcl", oldName
+ # Create the new sub
+ store_global "Tcl", newName, theSub
delete:
- delete commands[oldName]
+ null theSub
+ store_global "Tcl", oldName, theSub
goto done
- # fall through to a bad call.
-
error:
return_type = TCL_ERROR
retval = "wrong # args: should be \"rename oldName newName\""
1.3 +3 -2 parrot/lib/Parrot/Test/Tcl.pm
Index: Tcl.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Test/Tcl.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- Tcl.pm 8 Apr 2004 18:54:12 -0000 1.2
+++ Tcl.pm 19 Sep 2004 06:56:51 -0000 1.3
@@ -28,7 +28,8 @@
my $parrotdir = dirname $self->{parrot};
$TEST_PROG_ARGS = $ENV{TEST_PROG_ARGS} || '';
- my $args = $TEST_PROG_ARGS;
+ # Force any tcl tests to run with -G
+ my $args = "-G " . $TEST_PROG_ARGS;
# flatten filenames (don't use directories)
$lang_f = (File::Spec->splitpath($lang_f))[2];
@@ -42,7 +43,7 @@
my $exit_code = 0;
my $pass = 0;
- $cmd = "(cd " . $self->{relpath} . " && " . $self->{parrot} . "
languages/tcl/tcl.pbc ${args} $lang_f)";
+ $cmd = "(cd " . $self->{relpath} . " && " . $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
