Author: coke
Date: Tue Jan 3 08:39:18 2006
New Revision: 10865
Added:
trunk/languages/tcl/lib/builtins/cd.pir
trunk/languages/tcl/t/cmd_cd.t (contents, props changed)
Modified:
trunk/MANIFEST
trunk/languages/tcl/config/root.in
Log:
#38080: [TODO] Tcl - implement [cd]
Done, although the tests could use some cross-platforming.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Tue Jan 3 08:39:18 2006
@@ -1223,6 +1223,7 @@ languages/tcl/examples/power.tcl
languages/tcl/lib/builtins/auto_execok.pir [tcl]
languages/tcl/lib/builtins/auto_load.pir [tcl]
languages/tcl/lib/builtins/break.pir [tcl]
+languages/tcl/lib/builtins/cd.pir [tcl]
languages/tcl/lib/builtins/close.pir [tcl]
languages/tcl/lib/builtins/continue.pir [tcl]
languages/tcl/lib/builtins/exec.pir [tcl]
@@ -1311,6 +1312,7 @@ languages/tcl/t/cmd_append.t
languages/tcl/t/cmd_array.t [tcl]
languages/tcl/t/cmd_break.t [tcl]
languages/tcl/t/cmd_catch.t [tcl]
+languages/tcl/t/cmd_cd.t [tcl]
languages/tcl/t/cmd_concat.t [tcl]
languages/tcl/t/cmd_continue.t [tcl]
languages/tcl/t/cmd_eof.t [tcl]
Modified: trunk/languages/tcl/config/root.in
==============================================================================
--- trunk/languages/tcl/config/root.in (original)
+++ trunk/languages/tcl/config/root.in Tue Jan 3 08:39:18 2006
@@ -26,6 +26,7 @@ lib${slash}builtins${slash}auto_execok.p
lib${slash}builtins${slash}auto_load.pir \
lib${slash}builtins${slash}break.pir \
lib${slash}commands${slash}catch.pir \
+lib${slash}builtins${slash}cd.pir \
lib${slash}builtins${slash}close.pir \
lib${slash}commands${slash}concat.pir \
lib${slash}builtins${slash}continue.pir \
Added: trunk/languages/tcl/lib/builtins/cd.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/builtins/cd.pir Tue Jan 3 08:39:18 2006
@@ -0,0 +1,60 @@
+.namespace [ "_Tcl::builtins" ]
+
+.sub "cd"
+ .param int register_num
+ .param pmc argv
+
+ .local string pir_code,temp_code
+ .local int argc,directory_num,result_num
+ argc = argv
+ directory_num = 0
+
+ .local pmc compiler
+ compiler = find_global "_Tcl", "compile_dispatch"
+
+ if argc == 0 goto noargs
+ if argc == 1 goto got_dir
+
+ pir_code = ".throw ('wrong # args: should be \"cd\ ?dirName?\"')\n"
+ .return(register_num,pir_code)
+
+got_dir:
+ $P1 = argv[0]
+ (directory_num,temp_code) = compiler(register_num,$P1)
+ register_num = directory_num + 1
+ pir_code .= temp_code
+ goto cd_it
+
+noargs:
+ pir_code .= "$P"
+ $S1 = register_num
+ pir_code .= $S1
+ pir_code .= "= new .Env\n"
+ directory_num = register_num + 1
+ $S2 = directory_num
+ pir_code .= "$P"
+ pir_code .= $S2
+ pir_code .= "= $P"
+ pir_code .= $S1
+ pir_code .= "['HOME']\n"
+ register_num = directory_num + 1
+
+cd_it:
+ pir_code .= "$P"
+ $S1 = register_num
+ pir_code .= $S1
+ pir_code .= " = new .OS\n"
+ pir_code .= "$P"
+ result_num = register_num + 1
+ $S2 = result_num
+ pir_code .= $S2
+ pir_code .= " = $P"
+ pir_code .= $S1
+ pir_code .= '."cd"($P'
+ $S2 = directory_num
+ pir_code .= $S2
+ pir_code .= ")\n"
+
+ .return(result_num,pir_code)
+
+.end
Added: trunk/languages/tcl/t/cmd_cd.t
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/t/cmd_cd.t Tue Jan 3 08:39:18 2006
@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+
+use strict;
+use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
+use Parrot::Test tests => 3;
+use Test::More;
+
+language_output_is("tcl",<<'TCL',<<OUT,"cd too many args");
+ cd a b
+TCL
+wrong # args: should be "cd ?dirName?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<"OUT","cd home");
+ cd
+ puts [pwd]
+TCL
+$ENV{HOME}
+OUT
+
+
+#XXX portably write a test that cd's to a safe dir and checks it...
+SKIP: {
+ skip("Too dumb to create a directory") unless -d "/tmp";
+
+language_output_is("tcl",<<'TCL',<<"OUT","cd home");
+ cd /usr
+ puts [pwd]
+TCL
+/usr
+OUT
+}
