Author: coke
Date: Sun Jan 29 11:15:39 2006
New Revision: 11371
Added:
trunk/languages/tcl/lib/commands/binary.pir
trunk/languages/tcl/tools/tcl-test.pl
- copied, changed from r11331, trunk/languages/tcl/tcl-test.pl
Removed:
trunk/languages/tcl/tcl-test.pl
Modified:
trunk/MANIFEST
Log:
tcl -
1) relocate another perl script into the tools/ dir.
2) add rudimentary support for [binary]
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sun Jan 29 11:15:39 2006
@@ -1308,6 +1308,7 @@ languages/tcl/lib/builtins/while.tmt
languages/tcl/lib/commands/after.pir [tcl]
languages/tcl/lib/commands/append.pir [tcl]
languages/tcl/lib/commands/array.pir [tcl]
+languages/tcl/lib/commands/binary.pir [tcl]
languages/tcl/lib/commands/catch.pir [tcl]
languages/tcl/lib/commands/concat.pir [tcl]
languages/tcl/lib/commands/error.pir [tcl]
@@ -1422,12 +1423,12 @@ languages/tcl/t/tcl_glob.t
languages/tcl/t/tcl_misc.t [tcl]
languages/tcl/t/tcl_pir_compiler.t [tcl]
languages/tcl/t/tcl_var_subst.t [tcl]
-languages/tcl/tcl-test.pl [tcl]
languages/tcl/tcl.pir [tcl]
languages/tcl/tcl.pir_template [tcl]
languages/tcl/tools/gen_inline.pl [tcl]
languages/tcl/tools/gen_lib.pl [tcl]
languages/tcl/tools/tcl_harness.pl [tcl]
+languages/tcl/tools/tcl-test.pl [tcl]
languages/unlambda/README [unlambda]
languages/unlambda/hello.unl [unlambda]
languages/unlambda/t/harness [unlambda]
Added: trunk/languages/tcl/lib/commands/binary.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/commands/binary.pir Sun Jan 29 11:15:39 2006
@@ -0,0 +1,211 @@
+.namespace [ "Tcl" ]
+
+.sub "&binary"
+ .param pmc argv :slurpy
+
+ .local pmc retval
+
+ $I0 = argv
+ unless $I0 goto no_args
+
+ .local string subcommand_name
+ subcommand_name = shift argv
+ .local pmc subcommand_proc
+ null subcommand_proc
+
+ push_eh bad_args
+ subcommand_proc = find_global "_Tcl\0builtins\0binary", subcommand_name
+ clear_eh
+ .return subcommand_proc(argv)
+
+bad_args:
+ $S0 = "bad option \""
+ $S0 .= subcommand_name
+ $S0 .= "\": must be format or scan"
+
+ .throw ($S0)
+
+no_args:
+ .throw ('wrong # args: should be "binary option ?arg ...?"')
+
+.end
+
+.namespace [ "_Tcl\0builtins\0binary" ]
+
+.macro getBinaryArg ()
+ if argvIndex == argc goto out_of_args
+ argString = argv[argvIndex]
+ inc argvIndex
+.endm
+
+.sub "format"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ unless argc goto bad_args
+
+ .local pmc binary_types
+ binary_types = find_global '_Tcl', 'binary_types'
+
+ .local string outputString,formatString
+ outputString = binary:""
+ formatString = shift argv
+
+ # Loop over the chunks of the format string and generate the
+ # appropriate types. format strings consist of repeated chunks of
+ # type count? whitespace*
+ .local int pos,formatString_len,argvIndex,argc,count,digit,tempCount
+ .local string formatChar,argString
+ pos = 0
+ argvIndex = 0
+ argc = argv
+ # a count of -1 indicates that '*' was specified.
+ # a count of -2 indicates that no count was specified.
+ count = -2
+ formatString_len = length formatString
+
+format_loop:
+ if pos == formatString_len goto end_format_loop
+ formatChar = substr formatString,pos,1
+
+ $I1 = exists binary_types[formatChar]
+ unless $I1 goto bad_field_specifier
+
+ .local int num_pos
+ num_pos = pos + 1
+
+ $S0 = substr formatString, num_pos, 1
+ if $S0 != "*" goto get_int_count
+ count = -1
+ pos = num_pos
+ goto got_count
+
+get_int_count:
+ tempCount = 0
+ ## XXX countString = 0
+count_loop:
+ if num_pos == formatString_len goto count_loop_done
+ digit = ord formatString, num_pos
+ if digit < 48 goto count_loop_done
+ if digit > 57 goto count_loop_done
+ digit -= 48 # ascii
+ # XXXX
+ tempCount = tempCount * 10
+ tempCount += digit
+ inc num_pos
+ if num_pos == formatString_len goto count_loop_done
+ ## XXX digitString = substr formatString,pos,1
+ if num_pos == formatString_len goto count_loop_done
+ goto count_loop
+count_loop_done:
+ $I0 = num_pos - 1
+ if $I0 == pos goto got_default_count
+
+ pos = num_pos
+ count = tempCount
+ goto got_count
+
+got_default_count:
+ inc pos
+
+got_count:
+
+which_format:
+
+ if formatChar == "a" goto format_a
+ if formatChar == "A" goto format_A
+ if formatChar == "x" goto format_x
+
+ .throw('This error should never occur: must be missing a field specifier
implementation.')
+
+format_a:
+ .getBinaryArg()
+ if count == -1 goto format_a_star
+ if count >= 0 goto format_a_counted
+ count = 1
+
+format_a_counted:
+ $I0 = length argString
+ if $I0 < count goto format_a_padding
+ $S0 = substr argString, 0, count
+ outputString .= $S0
+ goto format_done
+
+format_a_padding:
+ outputString .= argString
+ count = count - $I0
+ $S0 = repeat binary:"\0", count
+ outputString .= $S0
+ goto format_done
+
+format_a_star:
+ outputString .= argString
+ goto format_done
+
+format_A:
+ .getBinaryArg()
+ if count == -1 goto format_A_star
+ if count >= 0 goto format_A_counted
+ count = 1
+
+format_A_counted:
+ $I0 = length argString
+ if $I0 < count goto format_A_padding
+ $S0 = substr argString, 0, count
+ outputString .= $S0
+ goto format_done
+
+format_A_padding:
+ outputString .= argString
+ count = count - $I0
+ $S0 = repeat " ", count
+ outputString .= $S0
+ goto format_done
+
+format_A_star:
+ outputString .= argString
+ goto format_done
+
+format_x:
+ outputString .= binary:"\0"
+
+ # done with formats.
+format_done:
+
+ goto format_loop
+end_format_loop:
+
+ print "ESCAPED OUTPUT IS:"
+ $S0 = escape outputString
+ print $S0
+ print_newline
+ .return(outputString)
+
+bad_args:
+ .throw ('wrong # args: should be "binary format formatString ?arg arg ...?"')
+bad_field_specifier:
+ $S0 = 'bad field specifier "'
+ $S0 .= formatChar
+ $S0 .= '"'
+ .throw ($S0)
+out_of_args:
+ .throw ('not enough arguments for all format specifiers')
+
+.end
+
+.sub "scan"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ unless argc > 2 goto bad_args
+
+bad_args:
+ .throw ('wrong # args: should be "binary scan value formatString ?varName
varName ...?"')
+
+.end
Copied: trunk/languages/tcl/tools/tcl-test.pl (from r11331,
trunk/languages/tcl/tcl-test.pl)
==============================================================================
--- trunk/languages/tcl/tcl-test.pl (original)
+++ trunk/languages/tcl/tools/tcl-test.pl Sun Jan 29 11:15:39 2006
@@ -9,6 +9,7 @@ $DIR = 't_tcl';
use File::Spec;
use Getopt::Std;
+use Text::Balanced; #XXX temporarily limit ourselves to perl 5.8...
use Test::Harness;
$|=1;
@@ -121,6 +122,47 @@ sub extract_tests {
test \s+ (\S+) # test ident
\s+ \{ ([^}]+) \} # test description
\s+ (?:\S+ \s+)? \{ \n # optional test harness info (ignoring)
+ ( (?:\s+ [^\n]+\n)+ ) # test body
+ \} \s+
+ (?: \{ ([^\n]+) \} # test result
+ | " ((?:[^"\\]|\\.)+) " #" (keep my editor happy)
+ | (\w+) )
+ ]sx;
+
+ while ($source =~ m[$regex]go) {
+ my ($name, $expl, $body, $out) = ($1, $2, $3, choose($4, unescape($5),
$6));
+
+ # make the test print the last line of output
+ # XXX This should be "print the last command". Which is harder.
+ $body =~ s/^(\s*)([^\n]+)\s*\Z/$1puts [$2]/m;
+
+ $tests{$name} = [$expl, $body, $out];
+ }
+
+ return %tests;
+}
+
+##
+## $preamble = extract_preamble($string)
+##
+## Extract the preamable for tests from the .test file.
+## This consists of any procedures defined in the test file outside of a test,
+## as well as any catch commands.
+##
+sub extract_preamble {
+ my ($source) = @_;
+ my $preamble;
+
+ my $regex = qr[
+ ^ # preambles begin the line
+ ( # then contain one of...
+ catch { # a catch statement
+
+ | # or
+ proc # a procedure definition
+ test \s+ (\S+) # test ident
+ \s+ \{ ([^}]+) \} # test description
+ \s+ (?:\S+ \s+)? \{ \n # optional test harness info (ignoring)
( (?:\s+ [^\n]+\n)+ ) # test body
\} \s+
(?: \{ ([^\n]+) \} # test result
