Author: coke
Date: Thu Aug 18 21:08:43 2005
New Revision: 8994
Added:
trunk/languages/tcl/t/cmd_info.t (contents, props changed)
Modified:
trunk/MANIFEST
trunk/languages/tcl/lib/commands/info.pir
Log:
Add tests for [info], and improve some of the functionality.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Thu Aug 18 21:08:43 2005
@@ -1447,6 +1447,7 @@ languages/tcl/t/cmd_format.t
languages/tcl/t/cmd_global.t [tcl]
languages/tcl/t/cmd_if.t [tcl]
languages/tcl/t/cmd_incr.t [tcl]
+languages/tcl/t/cmd_info.t [tcl]
languages/tcl/t/cmd_inline.t [tcl]
languages/tcl/t/cmd_join.t [tcl]
languages/tcl/t/cmd_lappend.t [tcl]
Modified: trunk/languages/tcl/lib/commands/info.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/info.pir (original)
+++ trunk/languages/tcl/lib/commands/info.pir Thu Aug 18 21:08:43 2005
@@ -10,7 +10,7 @@
.local pmc argv, retval
argv = foldup
- unless I3 goto bad_subcommand
+ unless I3 goto bad_args
.local string subcommand_name
subcommand_name = shift argv
@@ -21,19 +21,24 @@
subcommand_proc = find_global "_Tcl\0builtins\0info", subcommand_name
resume:
clear_eh
- if_null subcommand_proc, bad_args
+ if_null subcommand_proc, bad_subcommand
.return subcommand_proc(argv)
catch:
goto resume
-bad_args:
+bad_subcommand:
retval = new String
retval = "bad option \""
retval .= subcommand_name
- retval .= "\": must be args, body, cmdcount, commands, complete, default,
exists, functions, globals, hostname, level, library, loaded, locals,
nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or
vars\n"
+ retval .= "\": must be args, body, cmdcount, commands, complete, default,
exists, functions, globals, hostname, level, library, loaded, locals,
nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or
vars"
+
+ .return(TCL_ERROR,retval)
+bad_args:
+ retval = new String
+ retval = "wrong # args: should be \"info option ?arg arg ...?\""
.return(TCL_ERROR,retval)
.end
@@ -64,9 +69,8 @@ no_args:
bad_args:
retval = new String
- retval = "wrong # args: should be \"info args procname\"\n"
+ retval = "wrong # args: should be \"info args procname\""
.return (TCL_ERROR,retval)
-
.end
.sub "body"
@@ -79,7 +83,7 @@ bad_args:
.local pmc retval
.local string procname
- procname = shift argv
+ procname = argv[0]
$P1 = find_global "_Tcl", "proc_body"
$P2 = $P1[procname]
if_null $P2, no_body
@@ -90,33 +94,50 @@ no_body:
retval = "\""
retval .= procname
retval .= "\" isn't a procedure"
- .return (TCL_OK,retval)
+ .return (TCL_ERROR,retval)
bad_args:
retval = new String
- retval = "wrong # args: should be \"info body procname\"\n"
+ retval = "wrong # args: should be \"info body procname\""
.return (TCL_ERROR,retval)
.end
-# XXX not dealing with ?pattern? right now..
.sub "functions"
.param pmc argv
- .local pmc math_funcs,iterator,retval
.local int argc
argc = argv
- if argc != 0 goto bad_args
+ if argc > 1 goto bad_args
+
+ .local pmc math_funcs,iterator,retval
math_funcs = find_global "_Tcl", "functions"
iterator = new Iterator, math_funcs
iterator = 0
- retval = new TclList
+ retval = new .TclList
+
+ if argc == 0 goto loop
+ .local pmc globber,rule,match
+ globber = find_global "PGE", "glob"
+ $S1 = argv[0]
+ rule = globber($S1)
+pattern_loop:
+ $S0 = shift iterator
+ match = rule($S0)
+ unless match goto pattern_next
+ $P0 = new TclString
+ $P0 = $S0
+ push retval, $P0
+pattern_next:
+ if iterator goto pattern_loop
+ .return(TCL_OK,retval)
loop:
$S0 = shift iterator
- push retval, $S0
+ $P0 = new TclString
+ $P0 = $S0
+ push retval, $P0
if iterator goto loop
-
.return(TCL_OK,retval)
bad_args:
@@ -133,15 +154,18 @@ bad_args:
if argc != 1 goto bad_args
.local string varname
- varname = shift argv
+ varname = argv[0]
+
.local pmc value,retval
null value
- retval = new TclInt
+
push_eh global_catch
- $P1 = find_global "Tcl", varname
+ value = find_global "Tcl", varname
global_resume:
clear_eh
- if_null $P1, lex
+ if_null value, lex
+found_global:
+ retval = new TclInt
retval = 1
.return(TCL_OK,retval)
@@ -152,10 +176,12 @@ lex:
$P1 = find_global "_Tcl", "call_level"
$I1 = $P1
push_eh lex_catch
- $P1 = find_lex $I1, varname
+ value = find_lex $I1, varname
lex_resume:
clear_eh
- if_null $P1, nope
+ if_null value, nope
+found_lex:
+ retval = new TclInt
retval = 1
.return(TCL_OK,retval)
@@ -163,17 +189,30 @@ lex_catch:
goto lex_resume
nope:
+ retval = new TclInt
retval = 0
.return(TCL_OK,retval)
bad_args:
retval = new String
- retval = "wrong # args: should be \"info exists varName\"\n"
+ retval = "wrong # args: should be \"info exists varName\""
.return (TCL_ERROR,retval)
.end
-#XXX no error handling yet.
.sub "tclversion"
- $P1 = find_global "Tcl", "tcl_version"
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+
+ if argc != 0 goto bad_args
+
+ $P1 = find_global "Tcl", "$tcl_version"
.return(TCL_OK,$P1)
+
+bad_args:
+ $P1 = new String
+ $P1 = "wrong # args: should be \"info tclversion\""
+ .return (TCL_ERROR, $P1)
+
.end
Added: trunk/languages/tcl/t/cmd_info.t
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/t/cmd_info.t Thu Aug 18 21:08:43 2005
@@ -0,0 +1,154 @@
+#!/usr/bin/perl
+
+use strict;
+use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
+use Parrot::Test tests => 21;
+use Test::More;
+use vars qw($TODO);
+
+language_output_is("tcl",<<'TCL',<<OUT,"info no subcommand");
+ info
+TCL
+wrong # args: should be "info option ?arg arg ...?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info bad subcommand");
+ info bork
+TCL
+bad option "bork": must be args, body, cmdcount, commands, complete, default,
exists, functions, globals, hostname, level, library, loaded, locals,
nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or
vars
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args bad param");
+ info args
+TCL
+wrong # args: should be "info args procname"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args bad param too many");
+ info args a b c
+TCL
+wrong # args: should be "info args procname"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args no args");
+ proc me {} { puts 2 }
+ puts [info args me]
+TCL
+
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args one arg");
+ proc me {a} { puts 2 }
+ puts [info args me]
+TCL
+a
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args multi args");
+ proc me {a b c args} { puts 2 }
+ puts [info args me]
+TCL
+a b c args
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info args no proc");
+ puts [info args me]
+TCL
+"me" isn't a procedure
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info body no args");
+ info body
+TCL
+wrong # args: should be "info body procname"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info body too many args");
+ info body a b
+TCL
+wrong # args: should be "info body procname"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"info body bad proc");
+ info body bork
+TCL
+"bork" isn't a procedure
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info body normal proc");
+ proc say {a} {
+ puts $a
+ #fun
+ }
+ puts [info body say]
+TCL
+
+ puts $a
+ #fun
+
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info functions too many args");
+ info functions a b
+TCL
+wrong # args: should be "info functions ?pattern?"
+OUT
+
+TODO: {
+ local $TODO = "implement sorting before this can work reliably";
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info functions basic");
+ puts [info functions]
+TCL
+round wide sqrt sin double log10 atan hypot rand abs acos atan2 srand sinh
floor log int tanh tan asin ceil cos cosh exp pow fmod
+OUT
+}
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info functions pattern");
+ puts [info functions s??t]
+TCL
+sqrt
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info exists no args");
+ info exists
+TCL
+wrong # args: should be "info exists varName"
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info exists too many args");
+ info exists a b c
+TCL
+wrong # args: should be "info exists varName"
+OUT
+
+TODO: {
+ local $TODO = "info exists currently slightly borked";
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info exists true");
+ set a 1
+ puts [info exists a]
+TCL
+1
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info exists false");
+ puts [info exists a]
+TCL
+0
+OUT
+}
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info tclversion too many args");
+ info tclversion v
+TCL
+wrong # args: should be "info tclversion"
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"info tclversion");
+ if {[info tclversion] == [set tcl_version]} {
+ puts "ok"
+ }
+TCL
+ok
+OUT
