Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.602
diff -r1.602 MANIFEST
2219a2220
> languages/tcl/lib/commands/open.imc               [tcl]
2225a2227
> languages/tcl/lib/commands/string.imc             [tcl]
2269a2272
> languages/tcl/t/cmd_array.t                       [tcl]
2284a2288
> languages/tcl/t/cmd_string.t                      [tcl]
Index: config/gen/makefiles/tcl.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/tcl.in,v
retrieving revision 1.3
diff -r1.3 tcl.in
23a24
> lib/commands/open.imc \
29a31
> lib/commands/string.imc \
Index: languages/tcl/CHANGELOG
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/CHANGELOG,v
retrieving revision 1.1
diff -r1.1 CHANGELOG
8c8
< 		proc, expr, for, format, 
---
> 		proc, expr, eval, for, format, 
18a19,26
> 
> 2004-03-25
> 	* use improved imcc sub-calling syntax everywhere
> 	* more builtin procs supported:
> 		string (partial), array (partial)
>   	* [set] now deals with unknown variables properly
>  	* support for array variables 
> 	* builtin channels, e.g. [puts stderr eek]
Index: languages/tcl/TODO
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/TODO,v
retrieving revision 1.4
diff -r1.4 TODO
4a5,24
> =item misc
> 
> Find all uses of typeof, and convert to typeof (INT) rather than typeof
> (STR) - the comparisions should be faster.
> 
> 	./lib/commands/array.imc
> 	./lib/commands/open.imc
> 	./lib/commands/puts.imc
> 	./lib/commands/set.imc
> 	./lib/commands/source.imc
> 	./lib/expression.imc
> 	./lib/get_var.imc
> 	./lib/interpret.imc
> 
> =item parrot question
> 
>   unset (How do you remove a variable from the lexical scope ?) From
> p6i -  you can delete it from the Hash object. (great, except how
> do i access the hash if I'm using the default new_pad variant?)
> 
7,8c27,67
< array, error, and catch are currently not finished, though preliminary 
< subs exist for them.
---
> [array set] - written - write tests.
> 
> [array statistics] - useless?
> 
> [array anymore], [array donesearch] [array nextelement], [array startsearch]
> 
> [error], [catch]
> 
> [global]
> 
> [string repeat], [string replace], [string tolower],
> [string totitle], [string toupper], [string trim], [string trimleft],
> [string trimright], [string compare], [string equal], [string last]
> 
> =item channels
> 
> keep track of channels, include stdin, stdout, stderr - keep in a
> global hash of name to ParrotIO pmcs. Tie in with "puts" and other
> chanel based commands.
> 
> =item given [list]
> 
> [foreach]
> 
> =item given REs
> 
> "string match" (it's glob-style, but easy to do given REs)
> 
> =item given [string match]
> 
> The following items require [string match] to be implemented: [array get],
> [array names], [array unset]
> 
> =item given Unicode
> 
> Need unicode support for \u escapes, and for "string wordend",
> "string wordstart", "string is", "string bytelength", 
> 
> =item given arrays
> 
> [string map]
53,56d111
< =item speed
< 
< fact.tcl is currently about 8-12x slower with us than than tclsh on OS X.
< 
59,71c114,115
< run a tcl test suite and pass one test.
< 
< =item parrot
< 
< Parrot exception handlers are currently fubar and can't be enabled.
<  so referencing an unknown
< tcl variable will cause a parrot error. (this is quite bad, but won't
< be terrible until catch gets implemented)
< 
< =item parrot
< 
< array variables - we're very close to supporting them, but the inability
< to trap exceptions in parrot is stopping us from cleaning things up.
---
> run a tcl test suite (going to target 7.6p2) and pass one test.
> (then, pass most of them.) (then, retarget against tcl-latest)
78a123,124
> support default values (e.g.: proc joe {{drink coffee}} { slurp $drink } )
> 
119,120c165,166
< right now, anything in an expression is done as a parrot int, and anything
< returned from command is a parrot string. Should start passing around a 
---
> right now, anything in an expression is done as an int, and anything
> returned from a command is a PerlString. Should start passing around a 
122c168
< perate on a value be smart enough to know how to convert it to the 
---
> operate on a value be smart enough to know how to convert it to the 
137,140c183,185
<   catch, error 
< 
<   upvar, uplevel, global - should be pretty easy with the lexical pad
<       support in parrot.
---
>   upvar, uplevel  should be pretty easy with the lexical pad
>     support in parrot. Well, upvar, anyway. implementing uplevel
>     may require a rethunk. 
144,146c189
<   switch  {regexp regsub glob}
< 
<   array (lib/commands/array.imc exists, haven't touched it recently)
---
>   switch  {regexp regsub "string match"}
155,157c198
<   open close (puts channelid)
< 
<   string
---
>   open close
169,170d209
<   unset   (How do you remove a variable from the lexical scope ? - )
< 
177,178c216,217
<   http interp library
<   lindex load lset memory
---
>   http interp {setup our current single interp as an object?}
>   library lindex load lset memory
182c221,223
<   tclvars update variable vwait
---
>   update variable vwait
>  
>   also see "man n tclvars"
186a228,229
> Yes, much easier. We still have a ways to go, however. To run all the tests,
> run tclsh, sourcing "<tcl distro>tests/all".
190a234,247
> =item parrot
> 
> Get imcc to complain at compile time if you call a macro without passing
> all the arguments. (soon to be moot, neh?)
> 
> =item speed
> 
> fact.tcl is currently about 8-12x slower with us than than tclsh on OS X.
> 
> =item speed
> 
> Optimizations... I'm primarily concerned about functionality at this point,
> and have probably got some brain dead stuff that can be optimized now. 
> 
194c251
< of in PIR.. It can't be good to have all those branches.
---
> of in PIR macros. It can't be good to have all those branches.
196c253
< =item parrot
---
> =item 7.6 test suite
198c255
< Get imcc to complain if you call a macro without passing all the arguments.
---
> missing quite a bit to be able to think about running this, notably:
200c257
< =item parrot
---
> from all:
202c259
< Get imcc to NOT require a useless label when using the calling conventions:
---
> [foreach], [lsort], [glob], [string match], [puts stdout], catch
204,206c261
< This is pretty much a dead issue since we hardly use the .pcc_call style
< anymore. (yay, Melvin!) There are two cases where we MUST use it, in
< interpret when we call the appropriate command sub or op sub.
---
> from incr, one of the (easier?) tests to pass:
208c263,264
< =item misc
---
> [string compare], list, source, info, trace {is this still in tcl 8?}, 
> concat
210,211c266,270
< Optimizations... I'm primarily concerned about functionality at this point,
< and have probably got some brain dead stuff that can be optimized now. 
---
> which calls "def", which uses:
> 
> $tcl_platform, [info exists] , [info commands], unset, array vars,
> open, global, uplevel (GAH), regsub (GAH), fconfigure (GAH), file (GAH)
> exec (GAH)
Index: languages/tcl/tcl.imc_template
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/tcl.imc_template,v
retrieving revision 1.1
diff -r1.1 tcl.imc_template
133c133,146
< 
---
>   # Setup the default channelIds
>   $P1 = new PerlHash
>   $P2 = getstdin
>   $P1["stdin"] = $P2
>   $P2 = getstdout
>   $P1["stdout"] = $P2
>   $P2 = getstderr
>   $P1["stderr"] = $P2
>   global "channels" = $P1  
>   
>   # Setup the id # for channels..
>   $P1 = new PerlInt
>   $P1 = 1
>   global "next_channel_id" = $P1
160a174,183
> 
> # This handler is just supposed to get us back to the next
> # instruction. It's our job to deal with it in the calling
> # code, then.
> .emit
> __default_handler:
>   set P4, P5["_invoke_cc"]
>   set P5, P5["_P5"]
>   invoke P4
> .eom
Index: languages/tcl/examples/Makefile
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/examples/Makefile,v
retrieving revision 1.2
diff -r1.2 Makefile
3a4,6
> # with parrot 0.1.0-post, _dumper required being run out of the
> # top level directory 
> 
5c8
< 	../../../parrot ../tcl.pbc $@.tcl
---
> 	cd ../../.. && ./parrot languages/tcl/tcl.pbc languages/tcl/examples/$@.tcl
Index: languages/tcl/lib/expression.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/expression.imc,v
retrieving revision 1.1
diff -r1.1 expression.imc
147,151c147
<   $P1 = new PerlArray
<   $P1[0] = num_type
<   $P1[1] = value
< 
<   push chunks, $P1
---
>   push chunks, value
309c305,306
<   $P2 = chunk[1]
---
>   .local pmc func
>   func = chunk[1]
314c311
<   typeof $S3, $P2
---
>   typeof $S3, func
317,323c314
<   .pcc_begin prototyped
<     .arg result_stack
<     .pcc_call $P2
<     whydoineedthislabel:
<     .result result_stack
<     .result $I0
<   .pcc_end
---
>   (result_stack,$I0) = func(result_stack)
379a371,372
>   # XXX The octal code path doesn't work.
> 
430c423,425
<    value = $I0
---
>    value = new PerlArray
>    value[0] = INTEGER
>    value[1] = $I0 
Index: languages/tcl/lib/get_var.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/get_var.imc,v
retrieving revision 1.1
diff -r1.1 get_var.imc
8,13d7
< # XXXXXXXXXX!!!!!!!!!
< # this code isn't our code - it's cut and paste from 
< # cmd_set - all the right logic is buried in it, just need to
< # clean it up (and then rewrite cmd_set to call this code)
< # (when doing a get, anyway)
< 
31a26,31
>   .local int return_type
>   return_type = TCL_OK
> 
>   .local Exception_Handler ignore
>   newsub ignore, .Exception_Handler, __default_handler
> 
37,38c37,40
<   print "indexed\n"
<   find_lex lexical, -1, name
---
>   set_eh ignore
>     find_lex lexical, -1, name
>   clear_eh
>   isnull lexical, no_such_variable
47c49,55
<   print "That's not an array variable, putz"
---
>   return_type = TCL_ERROR
>   retval =  "can't read \""
>   retval .= name
>   retval .= "("
>   retval .= index
>   retval .= ")\": variable isn't array"
> 
51c59,63
<   find_lex lexical, -1, name
---
> 
>   set_eh ignore
>     find_lex lexical, -1, name
>   clear_eh
>   isnull lexical, no_such_variable 
53c65
<   if type != "PerlHash" goto get_scalar_ok
---
>   if type == "PerlString" goto get_scalar_ok
55c67,71
<   print "Can't do that, that's an array variable\n"
---
> get_scalar_bad:
>   return_type =TCL_ERROR
>   retval = "can't read \""
>   retval .= name
>   retval .= "\": variable is an array"
61a78,84
> no_such_variable:
>   return_type =TCL_ERROR
>   retval = "can't read \""
>   retval .= name
>   retval .= "\": no such variable"
>   goto done            
> 
68c91
<   .return 0
---
>   .return return_type
Index: languages/tcl/lib/interpret.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/interpret.imc,v
retrieving revision 1.1
diff -r1.1 interpret.imc
301,311c301
<   #
<   # XXX Need to leave this with verbose calling syntax until
<   # IMCC supports short version for Sub objects.
<   # 
<   .pcc_begin prototyped
<     .arg cooked_command
<     .pcc_call my_cmd
<     inevercallthislabelbutitsrequired:
<     .result return_type
<     .result retval
<   .pcc_end
---
>   (return_type,retval) = my_cmd(cooked_command)
Index: languages/tcl/lib/var_subst.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/var_subst.imc,v
retrieving revision 1.3
diff -r1.3 var_subst.imc
28a29,30
>   .param int raw
>    
104,106d105
<   # I'm not particularly happy with the way tcl matches up these ()'s...
<   # It appears to grab the last possible ), regardless of where in the word
<   # It may occur.
108,110c107,108
<   print "This looks like an array variable. Barfing!\n"
<   #index $I1, word, ")", -1
< 
---
>   index temppos, word, ")", -1
>   inc temppos
121,122d118
< #
< #  print "VARSUBSTR3\n" 
Index: languages/tcl/lib/commands/array.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/array.imc,v
retrieving revision 1.1
diff -r1.1 array.imc
7,8d6
<   # XXX this command was half implemented, need to revisit it.
<    
12,15c10,13
<   .local int ret_code
<   ret_code = 0
<   .local string ret_value
<   ret_value = ""
---
>   .local int return_type
>   return_type = TCL_OK
>   .local string retval
>   retval = ""
19c17
<   .local PerlHash the_array
---
>   .local pmc the_array
22c20
<   shift array_name, argv
---
>   array_name = argv[1]
24,25c22,23
<   #.local Exception_Handler ignore
<   #newsub ignore, .Exception_Handler, __ignore
---
>   .local Exception_Handler ignore
>   newsub ignore, .Exception_Handler, __default_handler
27,30c25,31
<   # For some reason, when we actually have an exception,
<   # the subcommand is coming back as "lexical "q" not found".
<   # Apparently there are side effects when using an exception
<   # handler that IMCC doesn't catch?
---
>   set_eh ignore
>     find_lex the_array, -1, array_name
>   clear_eh
> 
>   isnull the_array, array_no 
>   typeof $I0, the_array
>   if $I0 != .PerlHash goto array_no
32,58d32
<   # In trying to track down why argv was apparently updating, I added
<   # In this dumper call (which I should macroize, dammit)
<   # In doing that, I get:
< 
<   #--> Dumping 'before'
<   #[PerlArray] Illegal PMC enum (-1) in new
< 
<   # Which is bad. Ugh.
< 
<   # Why doesn't this work?
<  
<   #_dumper(argv,"before") 
< 
<   #print "About to ignore exception\n"
<   #set_eh ignore
<   find_lex the_array, -1, array_name
<   #clear_eh
<   #print "... and we're back\n"
< 
<   #_dumper(argv,"after")
<  
<   defined $I0, the_array
<   if $I0 == 0 goto array_no
< 
<   typeof $S0, the_array
< 
<   if $S0 != "PerlHash" goto array_no
60c34,35
<   goto array1
---
>   goto subcommand
> 
64c39
< array1:
---
> subcommand:
66d40
<   #print "HERE?\n" 
68c42
<   shift subcommand, argv
---
>   subcommand = argv[0]
70,77c44,45
<   #print "subcommand is '"
<   #print subcommand
<   #print " \n"
< 
<   argc = argv
< 
<   if subcommand == "anymore" goto NOTDONEYET
<   if subcommand == "donesearch" goto NOTDONEYET
---
>   #if subcommand == "anymore" goto NOTDONEYET
>   #if subcommand == "donesearch" goto NOTDONEYET
79,86c47,54
<   if subcommand == "get" goto NOTDONEYET
<   if subcommand == "names" goto NOTDONEYET
<   if subcommand == "nextelement" goto NOTDONEYET
<   if subcommand == "set" goto NOTDONEYET
<   if subcommand == "size" goto NOTDONEYET
<   if subcommand == "startsearch" goto NOTDONEYET
<   if subcommand == "statistics" goto NOTDONEYET
<   if subcommand == "unset" goto NOTDONEYET
---
>   #if subcommand == "get" goto NOTDONEYET
>   #if subcommand == "names" goto NOTDONEYET
>   #if subcommand == "nextelement" goto NOTDONEYET
>   if subcommand == "set" goto set
>   if subcommand == "size" goto size
>   #if subcommand == "startsearch" goto NOTDONEYET
>   #if subcommand == "statistics" goto NOTDONEYET
>   #if subcommand == "unset" goto NOTDONEYET
92c60,69
<   ret_value = is_array 
---
>   retval = is_array 
>   goto done
> 
> size:
>   if is_array == 0 goto size_none
>   $I0 = the_array
>   retval = $I0
>   goto done
> size_none:
>   retval = 0
95,98c72,94
< NOTDONEYET:
<   print "Array subcommand '"
<   print subcommand
<   print "' not implemented yet.\n"
---
> set:
>   # even only..
>   $I0 = argc % 2
>   if $I0 == 1 goto set_bad_args
>   if argc == 3 goto set_bad_args
>   
>   # starting at argv[3]/argv[4], pull out all the key/value pairs and
>   # set them.
>   .local int loop 
>   loop = 2
>   .local string key
>   .local string val
> set_loop:
>   key = argv[loop]
>   inc loop
>   val = argv[loop]
>   inc loop
>   the_array[key] = val
>   _dumper(the_array)
>   if loop >= argc goto set_loop_done
>   goto set_loop
> 
> set_loop_done:
100a97,101
> set_bad_args:
>  return_type = TCL_ERROR
>  retval = "wrong # args: should be array set arrayName list" 
>  goto done
> 
101a103
>   # XXX - this isn't the right error message.
107,108c109,110
<   .return ret_code
<   .return ret_value
---
>   .return return_type
>   .return retval
Index: languages/tcl/lib/commands/proc.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/proc.imc,v
retrieving revision 1.1
diff -r1.1 proc.imc
44,48d43
<   # XXX in retrospect, we shouldn't have to push this back into the globals.
<   
<   global "proc_body" = $P0
<   global "proc_args" = $P2
< 
Index: languages/tcl/lib/commands/puts.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/puts.imc,v
retrieving revision 1.3
diff -r1.3 puts.imc
6a7,9
>   .include "languages/tcl/lib/macros/debug.imc"
>   .const int debug = 0
> 
9a13
>   if argc > 3 goto error
17,21c21,22
<   $S1 = argv[0] 
<   if argc == 2 goto twoarg
<   print $S1
<   if argc == 1 goto newline
<   if argc > 2 goto error
---
>   if argc == 1 goto one_arg
>   if argc == 2 goto two_arg
23,24c24,29
< twoarg:
<   if $S1 != "-nonewline" goto error
---
> three_arg: 
>   .debug("three arg:\n")
>   $S1 = argv[0]
>   if $S1 != "-nonewline" goto bad_option
>   .local pmc channels 
>   channels = global "channels"
26,27c31,37
<   print $S2
<   goto done 
---
>   $P1 = channels[$S2]
>   # XXX isnull been flakey
>   $S0 = typeof $P1
>   if $S0 == "PerlUndef" goto bad_channel   
>   $S3 = argv[2]
>   print $P1, $S3
>   goto done
29,31c39,48
< error:
<   return_type = TCL_ERROR
<   retval = "Bad call to puts: \n"
---
> two_arg:
>   .debug("two arg:\n")
>   # The first arg could be the option, or it could be a channel
>   # figure out which.
>   $S2 = argv[0]
>   if $S2 != "-nonewline" goto two_arg_channel
> two_arg_nonewline:
>   .debug("two arg no newline:\n")
>   $S3 = argv[1] 
>   print $S3
34c51,67
< newline:
---
> two_arg_channel:  
>   .debug("two arg channel:\n")
>   $S3 = argv[1]
>   .local pmc channels 
>   channels = global "channels"
>   $P1 = channels[$S2]
>   # XXX isnull been flakey
>   $S0 = typeof $P1
>   if $S0 == "PerlUndef" goto bad_channel   
>   print $P1, $S3
>   print $P1, "\n"
>   goto done
> 
> one_arg:
>   .debug("one arg:\n")
>   $S1 = argv[0]
>   print $S1
35a69,88
>   goto done  
> 
> bad_channel:
>   return_type = TCL_ERROR
>   retval = "can not find channel named \""
>   retval .= $S2
>   retval .= "\""
>   goto done
> 
> bad_option:
>   return_type = TCL_ERROR
>   retval = "bad argument \""
>   retval .= $S1
>   retval .= "\": should be \"nonewline\"
>   goto done
>  
> error:
>   return_type = TCL_ERROR
>   retval = "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
>   goto done
Index: languages/tcl/lib/commands/set.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/set.imc,v
retrieving revision 1.3
diff -r1.3 set.imc
4,7d3
< # XXX don't forget to add in hooks so that we can't do:
< # set b 2
< # set b(c) 4
< 
18,19c14,15
<   #.local Exception_Handler ignore
<   #newsub ignore, .Exception_Handler, __ignore
---
>   .local Exception_Handler ignore
>   newsub ignore, .Exception_Handler, __default_handler
29d24
<   retval = TCL_OK
30a26,27
>   return_type = TCL_OK
>   retval = ""
60,70c57,60
<   find_lex lexical, -1, var
<   typeof type, lexical
<   if type != "PerlHash" goto get_array_bad
< 
< get_array_ok:
<   retval = lexical[key]
<   goto done
< 
< get_array_bad:
<   return_type = TCL_ERROR
<   retval =  "That's not an array variable, putz"
---
>   $P1 = new PerlArray
>   $P1[0] = var
>   $P1[1] = key
>   (return_type,retval) = __get_var($P1)
74,91c64,66
<   .debug("trying to get value of")
<   .debug(arg0)
<   .debug("\n")
<   find_lex lexical, -1, arg0
<   typeof type, lexical
<   if type == "PerlHash" goto get_scalar_bad
<   goto get_scalar_ok
< 
< get_scalar_bad:
<   return_type = TCL_ERROR
<   retval = "Can't do that, that's an array variable\n"
<   goto done
< 
< get_scalar_ok:
<   retval = lexical
<   .debug("Trying to get value of: ")
<   .debug(arg0)
<   .debug("\n")
---
>    $P1 = new PerlArray
>    $P1[0] = arg0
>    (return_type,retval) = __get_var($P1)
94a70,72
>   new value, .PerlString
>   value = argv[1]
> 
113,120c91,95
<   #set_eh ignore
<   find_lex lexical, -1, var
<   #clear_eh
< 
<   .local int bool
<   defined bool, lexical
<   unless bool, set_array_new
< 
---
>   set_eh ignore
>     find_lex lexical, -1, var
>   clear_eh
>   isnull lexical, set_array_new
>   
131c106,108
<   retval = "That's not an array variable, punk!\n"
---
>   retval =  "can't set \""
>   retval .= arg0
>   retval .= "\": variable isn't array"
150,152d126
<   new value, .PerlString
<   value = argv[1]
< 
164a139,145
> no_such_variable:
>   return_type =TCL_ERROR 
>   retval = "can't read \""
>   retval .= var
>   retval .= "\": no such variable"
>   goto done
> 
171c152
<   .return 0
---
>   .return return_type
174,180d154
< .end
< 
< # Should move this definition into a more global file.
< .sub __ignore
<   #print "Exception Handler Triggered\n"
<   set P2, P5["_invoke_cc"]
<   invoke P2
Index: languages/tcl/t/cmd_set.t
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/t/cmd_set.t,v
retrieving revision 1.1
diff -r1.1 cmd_set.t
5c5
< use Test::More tests => 2;
---
> use Test::More tests => 4;
22a23,35
> 
> $tcl = <<'EOTCL';
>  puts -nonewline $a
> EOTCL
> $expected = "can't read \"a\": no such variable";
> is(output($tcl),$expected,"missing lexical");
> 
> $tcl = <<'EOTCL';
>  set b 1
>  set b(c) 2
> EOTCL
> $expected = "can't set \"b(c)\": variable isn't array";
> is(output($tcl),$expected,"not an array");
Index: languages/tcl/t/tcl_var_subst.t
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/t/tcl_var_subst.t,v
retrieving revision 1.1
diff -r1.1 tcl_var_subst.t
5c5
< use Test::More tests => 4;
---
> use Test::More tests => 7;
36a37,57
> 
> $tcl = <<'EOTCL';
>  set a(b) whee
>  puts $a(b)
> EOTCL
> $expected = "whee\n";
> is(output($tcl),$expected,"array");
> 
> $tcl = <<'EOTCL';
>  set a 2
>  puts $a(b)
> EOTCL
> $expected = "can't read \"a(b)\": variable isn't array\n";
> is(output($tcl),$expected,"scalar as array");
> 
> $tcl = <<'EOTCL';
>  set a(b) 2
>  puts $a
> EOTCL
> $expected = "can't read \"a\": variable is an array\n";
> is(output($tcl),$expected,"array as scalar");
Index: languages/tcl/lib/commands/array.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/array.imc,v
retrieving revision 1.1
diff -r1.1 array.imc
7,8d6
<   # XXX this command was half implemented, need to revisit it.
<    
12,15c10,13
<   .local int ret_code
<   ret_code = 0
<   .local string ret_value
<   ret_value = ""
---
>   .local int return_type
>   return_type = TCL_OK
>   .local string retval
>   retval = ""
19c17
<   .local PerlHash the_array
---
>   .local pmc the_array
22c20
<   shift array_name, argv
---
>   array_name = argv[1]
24,25c22,23
<   #.local Exception_Handler ignore
<   #newsub ignore, .Exception_Handler, __ignore
---
>   .local Exception_Handler ignore
>   newsub ignore, .Exception_Handler, __default_handler
27,30c25,31
<   # For some reason, when we actually have an exception,
<   # the subcommand is coming back as "lexical "q" not found".
<   # Apparently there are side effects when using an exception
<   # handler that IMCC doesn't catch?
---
>   set_eh ignore
>     find_lex the_array, -1, array_name
>   clear_eh
> 
>   isnull the_array, array_no 
>   typeof $I0, the_array
>   if $I0 != .PerlHash goto array_no
32,58d32
<   # In trying to track down why argv was apparently updating, I added
<   # In this dumper call (which I should macroize, dammit)
<   # In doing that, I get:
< 
<   #--> Dumping 'before'
<   #[PerlArray] Illegal PMC enum (-1) in new
< 
<   # Which is bad. Ugh.
< 
<   # Why doesn't this work?
<  
<   #_dumper(argv,"before") 
< 
<   #print "About to ignore exception\n"
<   #set_eh ignore
<   find_lex the_array, -1, array_name
<   #clear_eh
<   #print "... and we're back\n"
< 
<   #_dumper(argv,"after")
<  
<   defined $I0, the_array
<   if $I0 == 0 goto array_no
< 
<   typeof $S0, the_array
< 
<   if $S0 != "PerlHash" goto array_no
60c34,35
<   goto array1
---
>   goto subcommand
> 
64c39
< array1:
---
> subcommand:
66d40
<   #print "HERE?\n" 
68c42
<   shift subcommand, argv
---
>   subcommand = argv[0]
70,77c44,45
<   #print "subcommand is '"
<   #print subcommand
<   #print " \n"
< 
<   argc = argv
< 
<   if subcommand == "anymore" goto NOTDONEYET
<   if subcommand == "donesearch" goto NOTDONEYET
---
>   #if subcommand == "anymore" goto NOTDONEYET
>   #if subcommand == "donesearch" goto NOTDONEYET
79,86c47,54
<   if subcommand == "get" goto NOTDONEYET
<   if subcommand == "names" goto NOTDONEYET
<   if subcommand == "nextelement" goto NOTDONEYET
<   if subcommand == "set" goto NOTDONEYET
<   if subcommand == "size" goto NOTDONEYET
<   if subcommand == "startsearch" goto NOTDONEYET
<   if subcommand == "statistics" goto NOTDONEYET
<   if subcommand == "unset" goto NOTDONEYET
---
>   #if subcommand == "get" goto NOTDONEYET
>   #if subcommand == "names" goto NOTDONEYET
>   #if subcommand == "nextelement" goto NOTDONEYET
>   if subcommand == "set" goto set
>   if subcommand == "size" goto size
>   #if subcommand == "startsearch" goto NOTDONEYET
>   #if subcommand == "statistics" goto NOTDONEYET
>   #if subcommand == "unset" goto NOTDONEYET
92c60,69
<   ret_value = is_array 
---
>   retval = is_array 
>   goto done
> 
> size:
>   if is_array == 0 goto size_none
>   $I0 = the_array
>   retval = $I0
>   goto done
> size_none:
>   retval = 0
95,98c72,94
< NOTDONEYET:
<   print "Array subcommand '"
<   print subcommand
<   print "' not implemented yet.\n"
---
> set:
>   # even only..
>   $I0 = argc % 2
>   if $I0 == 1 goto set_bad_args
>   if argc == 3 goto set_bad_args
>   
>   # starting at argv[3]/argv[4], pull out all the key/value pairs and
>   # set them.
>   .local int loop 
>   loop = 2
>   .local string key
>   .local string val
> set_loop:
>   key = argv[loop]
>   inc loop
>   val = argv[loop]
>   inc loop
>   the_array[key] = val
>   _dumper(the_array)
>   if loop >= argc goto set_loop_done
>   goto set_loop
> 
> set_loop_done:
100a97,101
> set_bad_args:
>  return_type = TCL_ERROR
>  retval = "wrong # args: should be array set arrayName list" 
>  goto done
> 
101a103
>   # XXX - this isn't the right error message.
107,108c109,110
<   .return ret_code
<   .return ret_value
---
>   .return return_type
>   .return retval
Index: languages/tcl/lib/commands/proc.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/proc.imc,v
retrieving revision 1.1
diff -r1.1 proc.imc
44,48d43
<   # XXX in retrospect, we shouldn't have to push this back into the globals.
<   
<   global "proc_body" = $P0
<   global "proc_args" = $P2
< 
Index: languages/tcl/lib/commands/puts.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/puts.imc,v
retrieving revision 1.3
diff -r1.3 puts.imc
6a7,9
>   .include "languages/tcl/lib/macros/debug.imc"
>   .const int debug = 0
> 
9a13
>   if argc > 3 goto error
17,21c21,22
<   $S1 = argv[0] 
<   if argc == 2 goto twoarg
<   print $S1
<   if argc == 1 goto newline
<   if argc > 2 goto error
---
>   if argc == 1 goto one_arg
>   if argc == 2 goto two_arg
23,24c24,29
< twoarg:
<   if $S1 != "-nonewline" goto error
---
> three_arg: 
>   .debug("three arg:\n")
>   $S1 = argv[0]
>   if $S1 != "-nonewline" goto bad_option
>   .local pmc channels 
>   channels = global "channels"
26,27c31,37
<   print $S2
<   goto done 
---
>   $P1 = channels[$S2]
>   # XXX isnull been flakey
>   $S0 = typeof $P1
>   if $S0 == "PerlUndef" goto bad_channel   
>   $S3 = argv[2]
>   print $P1, $S3
>   goto done
29,31c39,48
< error:
<   return_type = TCL_ERROR
<   retval = "Bad call to puts: \n"
---
> two_arg:
>   .debug("two arg:\n")
>   # The first arg could be the option, or it could be a channel
>   # figure out which.
>   $S2 = argv[0]
>   if $S2 != "-nonewline" goto two_arg_channel
> two_arg_nonewline:
>   .debug("two arg no newline:\n")
>   $S3 = argv[1] 
>   print $S3
34c51,67
< newline:
---
> two_arg_channel:  
>   .debug("two arg channel:\n")
>   $S3 = argv[1]
>   .local pmc channels 
>   channels = global "channels"
>   $P1 = channels[$S2]
>   # XXX isnull been flakey
>   $S0 = typeof $P1
>   if $S0 == "PerlUndef" goto bad_channel   
>   print $P1, $S3
>   print $P1, "\n"
>   goto done
> 
> one_arg:
>   .debug("one arg:\n")
>   $S1 = argv[0]
>   print $S1
35a69,88
>   goto done  
> 
> bad_channel:
>   return_type = TCL_ERROR
>   retval = "can not find channel named \""
>   retval .= $S2
>   retval .= "\""
>   goto done
> 
> bad_option:
>   return_type = TCL_ERROR
>   retval = "bad argument \""
>   retval .= $S1
>   retval .= "\": should be \"nonewline\"
>   goto done
>  
> error:
>   return_type = TCL_ERROR
>   retval = "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
>   goto done
Index: languages/tcl/lib/commands/set.imc
===================================================================
RCS file: /cvs/public/parrot/languages/tcl/lib/commands/set.imc,v
retrieving revision 1.3
diff -r1.3 set.imc
4,7d3
< # XXX don't forget to add in hooks so that we can't do:
< # set b 2
< # set b(c) 4
< 
18,19c14,15
<   #.local Exception_Handler ignore
<   #newsub ignore, .Exception_Handler, __ignore
---
>   .local Exception_Handler ignore
>   newsub ignore, .Exception_Handler, __default_handler
29d24
<   retval = TCL_OK
30a26,27
>   return_type = TCL_OK
>   retval = ""
60,70c57,60
<   find_lex lexical, -1, var
<   typeof type, lexical
<   if type != "PerlHash" goto get_array_bad
< 
< get_array_ok:
<   retval = lexical[key]
<   goto done
< 
< get_array_bad:
<   return_type = TCL_ERROR
<   retval =  "That's not an array variable, putz"
---
>   $P1 = new PerlArray
>   $P1[0] = var
>   $P1[1] = key
>   (return_type,retval) = __get_var($P1)
74,91c64,66
<   .debug("trying to get value of")
<   .debug(arg0)
<   .debug("\n")
<   find_lex lexical, -1, arg0
<   typeof type, lexical
<   if type == "PerlHash" goto get_scalar_bad
<   goto get_scalar_ok
< 
< get_scalar_bad:
<   return_type = TCL_ERROR
<   retval = "Can't do that, that's an array variable\n"
<   goto done
< 
< get_scalar_ok:
<   retval = lexical
<   .debug("Trying to get value of: ")
<   .debug(arg0)
<   .debug("\n")
---
>    $P1 = new PerlArray
>    $P1[0] = arg0
>    (return_type,retval) = __get_var($P1)
94a70,72
>   new value, .PerlString
>   value = argv[1]
> 
113,120c91,95
<   #set_eh ignore
<   find_lex lexical, -1, var
<   #clear_eh
< 
<   .local int bool
<   defined bool, lexical
<   unless bool, set_array_new
< 
---
>   set_eh ignore
>     find_lex lexical, -1, var
>   clear_eh
>   isnull lexical, set_array_new
>   
131c106,108
<   retval = "That's not an array variable, punk!\n"
---
>   retval =  "can't set \""
>   retval .= arg0
>   retval .= "\": variable isn't array"
150,152d126
<   new value, .PerlString
<   value = argv[1]
< 
164a139,145
> no_such_variable:
>   return_type =TCL_ERROR 
>   retval = "can't read \""
>   retval .= var
>   retval .= "\": no such variable"
>   goto done
> 
171c152
<   .return 0
---
>   .return return_type
174,180d154
< .end
< 
< # Should move this definition into a more global file.
< .sub __ignore
<   #print "Exception Handler Triggered\n"
<   set P2, P5["_invoke_cc"]
<   invoke P2