Author: mdiep
Date: Mon Aug 1 21:24:40 2005
New Revision: 8763
Added:
trunk/languages/tcl/lib/parser.pir
trunk/languages/tcl/lib/tclcommand.pir
trunk/languages/tcl/lib/tclconst.pir
trunk/languages/tcl/lib/tclvar.pir
Removed:
trunk/languages/tcl/classes/tclparser.pmc
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/tcl.in
trunk/languages/tcl/lib/commands/catch.pir
trunk/languages/tcl/lib/commands/eval.pir
trunk/languages/tcl/lib/commands/for.pir
trunk/languages/tcl/lib/commands/foreach.pir
trunk/languages/tcl/lib/commands/if.pir
trunk/languages/tcl/lib/commands/proc.pir
trunk/languages/tcl/lib/commands/puts.pir
trunk/languages/tcl/lib/commands/source.pir
trunk/languages/tcl/lib/commands/time.pir
trunk/languages/tcl/lib/commands/while.pir
trunk/languages/tcl/lib/expression.pir
trunk/languages/tcl/lib/interpret.pir
trunk/languages/tcl/lib/list_to_string.pir
trunk/languages/tcl/lib/string_to_list.pir
trunk/languages/tcl/lib/tclword.pir
trunk/languages/tcl/t/tcl_command_subst.t
trunk/languages/tcl/tcl.pir
trunk/languages/tcl/tcl.pir_template
trunk/languages/tcl/tcl.pl
Log:
The new PIR based parser for ParTcl:
* More correct parsing
* Broken octal escapes (at the moment)
* Poor documentation (also at the moment)
* A few other broken features that need tests
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Mon Aug 1 21:24:40 2005
@@ -1362,7 +1362,6 @@ languages/tcl/classes/tclint.pmc
languages/tcl/classes/tcllist.pmc [tcl]
languages/tcl/classes/tclstring.pmc [tcl]
languages/tcl/classes/tclobject.pmc [tcl]
-languages/tcl/classes/tclparser.pmc [tcl]
languages/tcl/docs/expr.pod [tcl]
languages/tcl/docs/hacks.pod [tcl]
languages/tcl/docs/howto.pod [tcl]
@@ -1421,7 +1420,11 @@ languages/tcl/lib/interpret.pir
languages/tcl/lib/list.pir [tcl]
languages/tcl/lib/list_to_string.pir [tcl]
languages/tcl/lib/macros/is_space.pir [tcl]
+languages/tcl/lib/parser.pir [tcl]
languages/tcl/lib/string_to_list.pir [tcl]
+languages/tcl/lib/tclcommand.pir [tcl]
+languages/tcl/lib/tclconst.pir [tcl]
+languages/tcl/lib/tclvar.pir [tcl]
languages/tcl/lib/tclword.pir [tcl]
languages/tcl/lib/tcl.p6r [tcl]
languages/tcl/lib/variables.pir [tcl]
Modified: trunk/config/gen/makefiles/tcl.in
==============================================================================
--- trunk/config/gen/makefiles/tcl.in (original)
+++ trunk/config/gen/makefiles/tcl.in Mon Aug 1 21:24:40 2005
@@ -14,8 +14,7 @@ PMCS = \
tclint \
tclfloat \
tcllist \
- tclarray \
- tclparser
+ tclarray
DEPS = $(PARROT) \
lib${slash}commands${slash}append.pir \
@@ -64,14 +63,16 @@ lib${slash}expression.pir \
lib${slash}get_var.pir \
lib${slash}interpret.pir \
lib${slash}list.pir \
+lib${slash}list_to_string.pir \
lib${slash}macros${slash}is_space.pir \
+lib${slash}parser.pir \
lib${slash}string_to_list.pir \
lib${slash}tcl.p6r \
lib${slash}variables.pir \
tcl.pir_template \
tcl.pl
-tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclword.pbc tcl.pir
+tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclcommand.pbc
lib${slash}tclconst.pbc lib${slash}tclvar.pbc lib${slash}tclword.pbc tcl.pir
$(PARROT) --output=tcl.pbc tcl.pir
pmcs:
@@ -89,6 +90,15 @@ lib${slash}tcllib.pir: $(DEPS)
lib${slash}tcllib.pbc: lib${slash}tcllib.pir
$(PARROT) --output=$(LIBPATH)${slash}tcllib.pbc
$(LIBPATH)${slash}tcllib.pir
+lib${slash}tclcommand.pbc: lib${slash}tclcommand.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclcommand.pbc
$(LIBPATH)${slash}tclcommand.pir
+
+lib${slash}tclconst.pbc: lib${slash}tclconst.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclconst.pbc
$(LIBPATH)${slash}tclconst.pir
+
+lib${slash}tclvar.pbc: lib${slash}tclvar.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclvar.pbc
$(LIBPATH)${slash}tclvar.pir
+
lib${slash}tclword.pbc: lib${slash}tclword.pir
$(PARROT) --output=$(LIBPATH)${slash}tclword.pbc
$(LIBPATH)${slash}tclword.pir
Modified: trunk/languages/tcl/lib/commands/catch.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/catch.pir (original)
+++ trunk/languages/tcl/lib/commands/catch.pir Mon Aug 1 21:24:40 2005
@@ -14,10 +14,10 @@
.local pmc retval
.local string varname,sigil_varname
.local string code
- .local pmc parser
+ .local pmc parse
.local pmc interpret
return_type = TCL_OK
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
.local int call_level
@@ -27,7 +27,7 @@
if argc == 0 goto badargs
if argc > 2 goto badargs
code = argv[0]
- $P1 = parser."parse"(code,0,0)
+ $P1 = parse(code)
register $P1
# ignoring $P0 here.
($I0,$P0) = interpret($P1)
Modified: trunk/languages/tcl/lib/commands/eval.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/eval.pir (original)
+++ trunk/languages/tcl/lib/commands/eval.pir Mon Aug 1 21:24:40 2005
@@ -17,9 +17,9 @@
.local int looper
- .local pmc parser
+ .local pmc parse
.local pmc interpret
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expr = ""
@@ -36,7 +36,7 @@ loop:
goto loop
loop_done:
- $P1 = parser."parse"(expr,0,0)
+ $P1 = parse(expr)
register $P1
.return interpret($P1)
Modified: trunk/languages/tcl/lib/commands/for.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/for.pir (original)
+++ trunk/languages/tcl/lib/commands/for.pir Mon Aug 1 21:24:40 2005
@@ -16,22 +16,22 @@
.local pmc retval
.local int return_type
- .local pmc parser, interpret
+ .local pmc parse, interpret
.local pmc expression_p, expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
# Parse the bits that are code.
$S0 = start_p
- start_parsed = parser."parse"($S0,0,0)
+ start_parsed = parse($S0)
register start_parsed
$S0 = next_p
- next_parsed = parser."parse"($S0,0,0)
+ next_parsed = parse($S0)
register next_parsed
$S0 = body_p
- body_parsed = parser."parse"($S0,0,0)
+ body_parsed = parse($S0)
register body_parsed
Modified: trunk/languages/tcl/lib/commands/foreach.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/foreach.pir (original)
+++ trunk/languages/tcl/lib/commands/foreach.pir Mon Aug 1 21:24:40 2005
@@ -7,7 +7,7 @@
argv = foldup
.local int return_type
- .local pmc parser,interpret,retval
+ .local pmc parse,interpret,retval
retval = new TclString
retval = ""
@@ -23,7 +23,7 @@
.local pmc __list
__list = find_global "_Tcl", "__list"
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
return_type = TCL_OK
@@ -77,7 +77,7 @@ got_list:
goto arg_loop
arg_done:
.local pmc parsed
- parsed = parser."parse"(body,0,0)
+ parsed = parse(body)
register parsed
.local pmc iterator
Modified: trunk/languages/tcl/lib/commands/if.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/if.pir (original)
+++ trunk/languages/tcl/lib/commands/if.pir Mon Aug 1 21:24:40 2005
@@ -24,9 +24,9 @@
handling_else = 0
.local int counter
- .local pmc parser,interpret
+ .local pmc parse,interpret
.local pmc expression_p,expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
@@ -109,7 +109,7 @@ do_else:
code = else
done:
- $P1 = parser."parse"(code,0,0)
+ $P1 = parse(code)
register $P1
.return interpret($P1) #tailcall
Modified: trunk/languages/tcl/lib/commands/proc.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/proc.pir (original)
+++ trunk/languages/tcl/lib/commands/proc.pir Mon Aug 1 21:24:40 2005
@@ -17,8 +17,8 @@ Create a PIR sub on the fly for this use
.local pmc retval
return_type = TCL_OK
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local pmc parse
+ parse = find_global "_Tcl", "parse"
.local pmc __list
__list = find_global "_Tcl", "__list"
@@ -36,7 +36,7 @@ got_args:
# Save the parsed body.
.local pmc parsed_body
$S0 = body_p
- parsed_body = parser."parse"($S0,0,0)
+ parsed_body = parse($S0)
register parsed_body
# XXX these need to go away - for now, we'll just escape
Modified: trunk/languages/tcl/lib/commands/puts.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/puts.pir (original)
+++ trunk/languages/tcl/lib/commands/puts.pir Mon Aug 1 21:24:40 2005
@@ -56,7 +56,8 @@ two_arg_channel:
goto done
one_arg:
- $S1 = argv[0]
+ $P0 = argv[0]
+ $S1 = $P0
print $S1
print "\n"
goto done
Modified: trunk/languages/tcl/lib/commands/source.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/source.pir (original)
+++ trunk/languages/tcl/lib/commands/source.pir Mon Aug 1 21:24:40 2005
@@ -14,9 +14,9 @@
.local string chunk, filename, contents
.local int code,type
- .local pmc retval, handle, parser
+ .local pmc retval, handle, parse
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
.local pmc interpret
interpret = find_global "_Tcl", "__interpret"
@@ -42,7 +42,7 @@ loop:
goto loop
gotfile:
- $P1 = parser."parse"(contents,0,0)
+ $P1 = parse(contents)
register $P1
(code,retval) = interpret($P1)
goto done
Modified: trunk/languages/tcl/lib/commands/time.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/time.pir (original)
+++ trunk/languages/tcl/lib/commands/time.pir Mon Aug 1 21:24:40 2005
@@ -15,8 +15,8 @@
.local int return_type
return_type = TCL_OK
- .local pmc parser,interpret
- parser = find_global "_Tcl", "parser"
+ .local pmc parse,interpret
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
.local string script
@@ -38,7 +38,7 @@ twoargs:
run:
script = argv[0]
- $P1 = parser."parse"(script,0,0)
+ $P1 = parse(script)
register $P1
time $N1
Modified: trunk/languages/tcl/lib/commands/while.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/while.pir (original)
+++ trunk/languages/tcl/lib/commands/while.pir Mon Aug 1 21:24:40 2005
@@ -12,20 +12,21 @@
.local pmc retval, parsed_code
.local int return_type
- .local pmc parser
+ .local pmc parse
.local pmc interpret
.local pmc expression_p
.local pmc expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
-while_loop:
$S0 = body_p
- parsed_code = parser."parse"($S0,0,0)
+ parsed_code = parse($S0)
register parsed_code
+
+while_loop:
(return_type,retval) = expression_p(cond_p)
if return_type == TCL_ERROR goto done_done
(return_type,retval) = expression_i(retval)
Modified: trunk/languages/tcl/lib/expression.pir
==============================================================================
--- trunk/languages/tcl/lib/expression.pir (original)
+++ trunk/languages/tcl/lib/expression.pir Mon Aug 1 21:24:40 2005
@@ -28,9 +28,6 @@ however, then we're returning the invoka
.local pmc precedences # Global list of operator precedence
precedences = find_global "_Tcl", "precedence"
- .local pmc parser
- parser = find_global "_Tcl", "parser"
-
if I3 == 1 goto pmc_arg
# if I2 isn't one here, we should blow up. But who's counting.
expr = S5
@@ -85,15 +82,34 @@ get_parenthetical:
# string and call ourselves recursively.
# (XXX should unroll this recursion.)
- if char != 40 goto get_variable
- # where do we close?
- $I1 = parser."match_close"(expr,chunk_start)
- #.match_close(expr,chunk_start,$I1)
- #error_S = "missing close parenthesis"
- if $I1 <= 0 goto die_horribly
- $I1 = $I1 - 2
- inc chunk_start
- substr $S1, expr, chunk_start, $I1
+ if char != 40 goto get_variable # (
+ .local int depth
+ depth = 1
+ $I1 = chunk_start
+get_paren_loop:
+ inc $I1
+ if $I1 >= expr_length goto die_horribly
+ $I0 = ord expr, $I1
+ if $I0 == 41 goto get_paren_loop_right
+ if $I0 == 40 goto get_paren_loop_left
+ if $I0 == 92 goto get_paren_loop_backslash
+ goto get_paren_loop
+get_paren_loop_right:
+ dec depth
+ if depth == 0 goto get_paren_done
+ goto get_paren_loop
+get_paren_loop_left:
+ inc depth
+ goto get_paren_loop
+get_paren_loop_backslash:
+ inc $I1
+ goto get_paren_loop
+
+get_paren_done:
+ $I0 = $I1 - chunk_start
+ dec $I0
+ inc chunk_start
+ substr $S1, expr, chunk_start, $I0
$P9 = new String
$P9 = $S1
@@ -108,7 +124,7 @@ get_parenthetical:
chunk[1] = retval
push chunks, chunk
- chunk_start = chunk_start + $I1
+ chunk_start += $I0
inc chunk_start
goto chunk_loop
@@ -854,21 +870,42 @@ dd:
.local pmc func,operand
.local int start_paren_pos
-
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local int expr_length
+ expr_length = length expr
# if we are starting with the text of a defined function,
# and it's followed by a (),
index start_paren_pos, expr, "(", start
if start_paren_pos == -1 goto fail
- #.match_close(expr,start_paren_pos,$I1)
- $I1 = parser."match_close"(expr,start_paren_pos)
- if $I1 <= 0 goto fail
+
+ .local int depth
+ depth = 1
+ $I0 = start_paren_pos
+loop:
+ inc $I0
+ if $I0 >= expr_length goto fail
+ $I1 = ord expr, $I0
+ if $I1 == 40 goto left
+ if $I1 == 41 goto right
+ if $I1 == 92 goto backslash
+ goto loop
+left:
+ inc depth
+ goto loop
+right:
+ dec depth
+ if depth == 0 goto loop_done
+ goto loop
+backslash:
+ inc $I0
+ goto loop
+
+loop_done:
+ $I1 = $I0 - start_paren_pos
+ dec $I1
# so, we know that the function name must be before the first (
-
.local int len
len = start_paren_pos - start
@@ -888,7 +925,7 @@ dd:
inc start_paren_pos
.local int len_operand
- len_operand = $I1 - 2
+ len_operand = $I1
substr $S1, expr, start_paren_pos, len_operand
$P9 = new String
Modified: trunk/languages/tcl/lib/interpret.pir
==============================================================================
--- trunk/languages/tcl/lib/interpret.pir (original)
+++ trunk/languages/tcl/lib/interpret.pir Mon Aug 1 21:24:40 2005
@@ -14,83 +14,18 @@ Given a pre-parsed chunk of Tcl, interpr
return_type = TCL_OK
.local pmc retval
- # Which command are we processing?
- .local int command_num,num_commands
- command_num = -1
- num_commands = commands
- .local pmc command
- .local string proc,sigil_proc
- .local pmc args,my_cmd,parsed_body,argument_list
-
-end_scope:
- inc command_num
- if command_num == num_commands goto done
- if return_type != TCL_OK goto done
- command = commands[command_num]
-
- # this should stringify the tclword object, which performs
- # all necessary substitutions.
- $P0 = command[0]
- (return_type,retval) = $P0.__get_pmc()
-
- if return_type != TCL_OK goto done
- proc = retval
- sigil_proc = "&" . proc
-
- .local int num_args,arg_num
- num_args = command
- arg_num = 1
-
- # The subs we're calling expect flattened args,
- # as passed with the ":flag" arg adverb.
-
- .local string caller_sub_text
-
- push_eh no_command
- my_cmd = find_global "Tcl", sigil_proc
- clear_eh
- # we can't delete commands, so we store deleted commands
- # as null PMCs
- isnull my_cmd, no_command
+ .local int elems, i
+ elems = commands
+ i = 0
-got_command:
- .local pmc folded_args
- folded_args = new TclList
- .local pmc current_word
-
-loop:
- if arg_num == num_args goto loop_done
- current_word = command[arg_num]
- (return_type,retval) = current_word.__get_pmc()
+ .local pmc command
+next_command:
+ if i == elems goto done
if return_type != TCL_OK goto done
-
- push folded_args, retval
- inc arg_num
- goto loop
-
-loop_done:
- (return_type,retval) = my_cmd(folded_args :flat)
- goto end_scope
-
-no_command:
- $P1 = find_global "Tcl", "$tcl_interactive"
- unless $P1 goto no_command_non_interactive
-
- # XXX Should probably make sure this wasn't redefined on us.
- my_cmd = find_global "Tcl", "&unknown"
-
- # Add the command into the unknown handler, and fix our bookkeeping
- unshift command, proc
- inc num_args
-
- goto got_command
-
-no_command_non_interactive:
- return_type = TCL_ERROR
- $S0 = "invalid command name \""
- $S0 .= proc
- $S0 .= "\""
- retval = $S0
+ command = commands[i]
+ (return_type, retval) = command.interpret()
+ inc i
+ goto next_command
done:
.return(return_type,retval)
Modified: trunk/languages/tcl/lib/list_to_string.pir
==============================================================================
--- trunk/languages/tcl/lib/list_to_string.pir (original)
+++ trunk/languages/tcl/lib/list_to_string.pir Mon Aug 1 21:24:40 2005
@@ -42,6 +42,24 @@ right_brace:
check_list_done:
if count != 0 goto escape
+ # {}'d constructs
+check_spaces:
+ $I0 = find_whitespace $S0, 0
+ if $I0 != -1 goto quote
+
+check_left_bracket:
+ $I0 = index $S0, "["
+ if $I0 != -1 goto quote
+
+check_dollar_sign:
+ $I0 = index $S0, "$"
+ if $I0 != -1 goto quote
+
+check_semi_colon:
+ $I0 = index $S0, ";"
+ if $I0 != -1 goto quote
+
+ # \'d constructs
check_right_bracket:
$I0 = index $S0, "]"
if $I0 != -1 goto escape
@@ -50,7 +68,11 @@ check_backslash:
$I0 = index $S0, "\\"
if $I0 != -1 goto escape
- goto check_spaces
+check_quotes:
+ $I0 = index $S0, "\""
+ if $I0 != -1 goto escape
+
+ goto append_elem
escape:
$P0 = new String
@@ -61,26 +83,9 @@ escape:
$P0."replace"("{", "\\{")
$P0."replace"(" ", "\\ ")
$P0."replace"("]", "\\]")
+ $P0."replace"("\"", "\\\"")
- $S0 = $P0
- goto append_elem
-
-check_spaces:
- $I0 = find_whitespace $S0, 0
- if $I0 != -1 goto quote
-
-check_left_bracket:
- $I0 = index $S0, "["
- if $I0 != -1 goto quote
-
-check_dollar_sign:
- $I0 = index $S0, "$"
- if $I0 != -1 goto quote
-
-check_semi_colon:
- $I0 = index $S0, ";"
- if $I0 != -1 goto quote
-
+ $S0 = $P0
goto append_elem
empty:
Added: trunk/languages/tcl/lib/parser.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/parser.pir Mon Aug 1 21:24:40 2005
@@ -0,0 +1,423 @@
+.namespace [ "_Tcl" ]
+
+.sub parse
+ .param string tcl_code
+
+ .local int len
+ len = length tcl_code
+
+ # perform the backslash-newline substitution
+ $I0 = -1
+loop:
+ inc $I0
+ if $I0 >= len goto get_commands
+ $I1 = ord tcl_code, $I0
+ if $I1 != 92 goto loop # \\
+ inc $I0
+ $I2 = $I0
+ $I1 = ord tcl_code, $I2
+ if $I1 != 10 goto loop # \n
+space:
+ inc $I2
+ if $I0 >= len goto get_commands
+ $I1 = is_whitespace tcl_code, $I2
+ if $I1 == 0 goto not_space
+ goto space
+not_space:
+ dec $I0
+ $I1 = $I2 - $I0
+ substr tcl_code, $I0, $I1, " "
+ dec $I1
+ len -= $I1
+ goto loop
+
+get_commands:
+ # an array of commands
+ .local pmc commands
+ commands = new TclList
+
+ # position in the file
+ .local int pos
+ pos = 0
+ # characters that end commands
+ .local pmc chars
+ chars = new Hash
+ chars[10] = 1 # \n
+ chars[59] = 1 # ;
+
+next_command:
+ .local pmc command
+ (command, pos) = get_command(tcl_code, chars, pos)
+ isnull command, done
+
+ push commands, command
+ goto next_command
+
+done:
+ .return(commands)
+.end
+
+.sub get_command
+ .param string tcl_code
+ .param pmc chars
+ .param int pos
+
+get:
+ .local pmc command
+ null command
+
+ # try to get a command name
+ .local pmc word
+ (word, pos) = get_word(tcl_code, chars, pos)
+ isnull word, check
+
+ $I0 = find_type "TclCommand"
+ command = new $I0
+ setattribute command, "TclCommand\x00name", word
+
+next_word:
+ (word, pos) = get_word(tcl_code, chars, pos)
+ isnull word, done
+ push command, word
+ goto next_word
+
+check:
+ $I0 = length tcl_code
+ if pos >= $I0 goto done
+ inc pos
+ goto get
+
+done:
+ inc pos
+ .return(command, pos)
+.end
+
+.sub get_word
+ .param string tcl_code
+ .param pmc chars
+ .param int pos
+ dec pos
+
+ .local int len
+ len = length tcl_code
+
+ .local pmc word
+ null word
+
+eat_space:
+ inc pos
+ if pos >= len goto done
+ $I0 = ord tcl_code, pos
+ $I0 = exists chars[$I0]
+ if $I0 == 1 goto done
+ $I0 = is_whitespace tcl_code, pos
+ if $I0 == 1 goto eat_space
+
+ if pos >= len goto done
+
+ .local pmc dispatch
+ dispatch = new Hash
+ dispatch[ 34] = "get_quote" # "
+ dispatch[123] = "get_brace" # {
+
+parse_word:
+ .local int char
+ char = ord tcl_code, pos
+
+ $I0 = exists dispatch[char]
+ if $I0 == 1 goto dispatch_sub
+
+default:
+ .local int start
+ start = pos
+ $I0 = find_type "TclWord"
+ word = new $I0
+ dec pos
+loop:
+ inc pos
+ if pos >= len goto have_word
+ $I0 = is_whitespace tcl_code, pos
+ if $I0 == 1 goto have_word
+
+ $I0 = ord tcl_code, pos
+ if $I0 == 92 goto backslash # \
+ if $I0 == 36 goto variable # $
+ if $I0 == 91 goto subcommand # [
+ $I0 = exists chars[$I0]
+ if $I0 goto have_word
+ goto loop
+backslash:
+ inc pos
+ goto loop
+variable:
+ $I0 = pos - start
+ if $I0 == 0 goto variable2
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+
+variable2:
+ ($P0, pos) = parse_variable(tcl_code, pos)
+ push word, $P0
+ dec pos
+ start = pos + 1
+ goto loop
+subcommand:
+ $I0 = pos - start
+ if $I0 == 0 goto subcommand2
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+
+subcommand2:
+ ($P0, pos) = get_subcommand(tcl_code, pos)
+ push word, $P0
+
+ start = pos + 1
+ goto loop
+
+have_word:
+ $I0 = pos - start
+ if $I0 == 0 goto done
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+ goto done
+
+done:
+ isnull word, really_done
+ $I0 = word
+ if $I0 != 1 goto really_done
+ word = word[0]
+ goto really_done
+
+dispatch_sub:
+ $S0 = dispatch[char]
+ $P0 = find_name $S0
+ (word, pos) = $P0(tcl_code, pos)
+ inc pos
+
+really_done:
+ .return(word, pos)
+.end
+
+.sub get_quote
+ .param string tcl_code
+ .param int pos
+
+ .local int start
+ start = pos + 1
+ .local int len
+ len = length tcl_code
+
+ .local pmc word
+ $I0 = find_type "TclWord"
+ word = new $I0
+
+loop:
+ inc pos
+ if pos >= len goto missing_quote
+
+ $I0 = ord tcl_code, pos
+ if $I0 == 92 goto backslash # \
+ if $I0 == 36 goto variable # $
+ if $I0 == 91 goto subcommand # [
+ if $I0 == 34 goto done # "
+ goto loop
+backslash:
+ inc pos
+ goto loop
+variable:
+ $I0 = pos - start
+ if $I0 == 0 goto variable2
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+
+variable2:
+ ($P0, pos) = parse_variable(tcl_code, pos)
+ push word, $P0
+ dec pos
+ start = pos + 1
+ goto loop
+subcommand:
+ $I0 = pos - start
+ if $I0 == 0 goto subcommand2
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+
+subcommand2:
+ ($P0, pos) = get_subcommand(tcl_code, pos)
+ push word, $P0
+
+ start = pos + 1
+ goto loop
+
+missing_quote:
+ $P0 = new Exception
+ $P0["_message"] = "missing quote"
+ throw $P0
+
+done:
+ $I0 = pos - start
+ $S0 = substr tcl_code, start, $I0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+ push word, $P0
+
+ .return(word, pos)
+.end
+
+.sub get_brace
+ .param string tcl_code
+ .param int pos
+
+ .local int start, len
+ start = pos + 1
+ len = length tcl_code
+
+ .local int depth
+ depth = 1
+loop:
+ inc pos
+ if pos >= len goto missing_close_brace
+
+ $I0 = ord tcl_code, pos
+ if $I0 == 92 goto backslash # \
+ if $I0 == 123 goto left # {
+ if $I0 == 125 goto right # }
+ goto loop
+backslash:
+ inc pos
+ goto loop
+left:
+ inc depth
+ goto loop
+right:
+ dec depth
+ if depth == 0 goto done
+ goto loop
+
+missing_close_brace:
+ $P0 = new Exception
+ $P0["_message"] = "missing close-brace"
+ throw $P0
+
+done:
+ $I0 = pos - start
+
+ $S0 = substr tcl_code, start, $I0
+ $P0 = new String
+ $P0 = $S0
+ $P0.replace("\\","\\\\")
+ $S0 = $P0
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = $S0
+
+ .return($P0, pos)
+.end
+
+.sub get_subcommand
+ .param string tcl_code
+ .param int pos
+ inc pos
+
+ .local pmc chars
+ chars = new Hash
+ chars[93] = 1 # ]
+
+ ($P0, $I0) = get_command(tcl_code, chars, pos)
+ dec $I0
+
+ .return($P0, $I0)
+.end
+
+.sub parse_variable
+ .param string tcl_code
+ .param int pos
+ inc pos
+
+ .local int start
+ .local int len
+ len = length tcl_code
+
+ if pos >= len goto failed
+ $I0 = ord tcl_code, pos
+ if $I0 == 123 goto braces # {
+
+name:
+ start = pos
+ dec pos
+char:
+ inc pos
+ if pos >= len goto check_length
+ $I0 = is_wordchar tcl_code, pos
+ if $I0 goto char
+ $I0 = ord tcl_code, pos
+ if $I0 == 58 goto colon # :
+ if $I0 == 40 goto index #
+ # goto check_length
+
+check_length:
+ len = pos - start
+ if len == 0 goto failed
+ goto done
+
+colon:
+ inc pos
+ $I0 = ord tcl_code, pos
+ if $I0 == 58 goto char
+ dec pos
+ goto check_length
+
+index:
+ pos = index tcl_code, ")", pos
+ if pos == -1 goto missing_paren
+ inc pos
+ goto check_length
+
+failed:
+ $I0 = find_type "TclConst"
+ $P0 = new $I0
+ $P0 = "$"
+ .return($P0, start)
+
+missing_paren:
+ $P0 = new Exception
+ $P0["_message"] = "missing paren"
+ throw $P0
+
+missing_close_brace:
+ $P0 = new Exception
+ $P0["_message"] = "missing close-brace for variable name"
+ throw $P0
+
+braces:
+ inc pos
+ start = pos
+ pos = index tcl_code, "}", start
+ if pos == -1 goto missing_close_brace
+ len = pos - start
+ inc pos
+ # got done
+
+done:
+ $S0 = substr tcl_code, start, len
+ $I0 = find_type "TclVar"
+ $P0 = new $I0
+ $P0 = $S0
+ .return($P0, pos)
+.end
Modified: trunk/languages/tcl/lib/string_to_list.pir
==============================================================================
--- trunk/languages/tcl/lib/string_to_list.pir (original)
+++ trunk/languages/tcl/lib/string_to_list.pir Mon Aug 1 21:24:40 2005
@@ -1,5 +1,3 @@
-# XXX move into a PMC vtable
-
.namespace [ "_Tcl" ]
.sub __stringToList
@@ -10,32 +8,118 @@
.local pmc retval
retval = new TclList
-
- .local pmc parsed_str
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local int pos, len
+ # we're going to increment before we use it, so set it to 0-1
+ pos = -1
+ len = length str
+
+eat_space:
+ inc pos
+ $I0 = is_whitespace str, pos
+ if $I0 == 1 goto eat_space
+
+loop:
+ if pos >= len goto done
- push_eh parse_error
- parsed_str = parser."parse"(str,0,1)
- clear_eh
- register parsed_str
+ # check if the first char is a {
+ $I0 = ord str, pos
+ if $I0 == 123 goto list
+ if $I0 == 34 goto quote
+
+not_list:
+ $I0 = find_whitespace str, pos
+ if $I0 == -1 goto loop_done
- $I0 = parsed_str
- if $I0 == 0 goto done
-
- retval = shift parsed_str
-
- # XXX If there is more than one entry in the parsed_str array, then
- # there's probably an error condition we need to raise.
+ # extract the element
+ $I1 = $I0 - pos
+ $S0 = substr str, pos, $I1
+
+ # add it to the list
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+ # find the next pos
+ pos = $I0
+ goto eat_space
+
+loop_done:
+ # grab the rest of the string
+ $I1 = len - pos
+ $S0 = substr str, pos, $I1
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
goto done
+
+ # find the closing '"'
+quote:
+ inc pos
+ $I1 = pos
+quote_loop:
+ $I0 = ord str, $I1
+ if $I0 == 92 goto quote_backslash
+ if $I0 == 34 goto found_quote
+ inc $I1
+ goto quote_loop
+quote_backslash:
+ $I1 += 2
+ goto quote_loop
+found_quote:
+ $I0 = $I1 - pos
+ $S0 = substr str, pos, $I0
+
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+
+ pos = $I1
+ inc pos
+ goto loop
+
+list:
+ .local int depth
+ depth = 1
+ $I1 = pos
+find_close_bracket:
+ inc $I1
+ if $I1 >= len goto unmatched_open_brace
+ $I0 = ord str, $I1
+ if $I0 == 123 goto left_bracket
+ if $I0 == 125 goto right_bracket
+ if $I0 == 92 goto backslash
+ goto find_close_bracket
+backslash:
+ inc $I1
+ goto find_close_bracket
+left_bracket:
+ inc depth
+ goto find_close_bracket
+right_bracket:
+ dec depth
+ if depth == 0 goto found_close_bracket
+ goto find_close_bracket
+
+found_close_bracket:
+ # length -- if we have "{ }", pos and $I0 should both be 1
+ $I0 = $I1 - pos
+ $I0 -= 1
+ inc pos
+ $S0 = substr str, pos, $I0
+ pos += $I0
+ pos += 2
-parse_error:
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+
+ goto loop
+
+unmatched_open_brace:
return_type = TCL_ERROR
- $S0 = P5["_message"]
retval = new String
- retval = $S0
+ retval = "unmatched open brace in list"
# goto done
done:
Added: trunk/languages/tcl/lib/tclcommand.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/tclcommand.pir Mon Aug 1 21:24:40 2005
@@ -0,0 +1,106 @@
+.namespace [ "TclCommand" ]
+
+.HLL "Tcl", "tcl_group"
+
+# return codes
+ .const int TCL_OK = 0
+ .const int TCL_ERROR = 1
+ .const int TCL_RETURN = 2
+ .const int TCL_BREAK = 3
+ .const int TCL_CONTINUE = 4
+
+=head2 __class_init
+
+Define the attributes required for the class.
+
+=cut
+
+.sub __class_init @LOAD
+ $P0 = getclass "TclList"
+ $P1 = subclass $P0, "TclCommand"
+ addattribute $P1, "name"
+.end
+
+=head2 __init
+
+Initialize the attributes for an instance of the class
+
+=cut
+
+.sub __init method
+ $P0 = new TclString
+ setattribute self, "TclCommand\x00name", $P0
+.end
+
+=head2 interpret
+
+Execute the command.
+
+=cut
+
+.sub interpret method
+ .local pmc retval
+ .local int return_type
+ return_type = TCL_OK
+
+ .local string name
+ $P0 = getattribute self, "TclCommand\x00name"
+ (return_type, retval) = $P0.interpret()
+ if return_type != TCL_OK goto done
+ name = retval
+
+ .local int elems, i
+ elems = self
+ i = 0
+
+ .local pmc cmd
+ push_eh no_command
+ $S0 = "&" . name
+ cmd = find_global "Tcl", $S0
+ clear_eh
+
+ # we can't delete commands, so we store deleted commands
+ # as null PMCs
+ isnull cmd, no_command
+
+execute:
+ .local pmc args
+ args = new TclList
+ .local pmc word
+loop:
+ if i == elems goto loop_done
+
+ word = self[i]
+ (return_type, retval) = word.interpret()
+ if return_type != TCL_OK goto done
+
+ push args, retval
+ inc i
+ goto loop
+
+loop_done:
+ (return_type, retval) = cmd(args :flat)
+
+done:
+ .return(return_type, retval)
+
+no_command:
+ $P1 = find_global "Tcl", "$tcl_interactive"
+ unless $P1 goto no_command_non_interactive
+
+ # XXX Should probably make sure this wasn't redefined on us.
+ cmd = find_global "Tcl", "&unknown"
+
+ # Add the command into the unknown handler, and fix our bookkeeping
+ unshift self, name
+ inc elems
+ goto execute
+
+no_command_non_interactive:
+ return_type = TCL_ERROR
+ $S0 = "invalid command name \""
+ $S0 .= name
+ $S0 .= "\""
+ retval = $S0
+ goto done
+.end
Added: trunk/languages/tcl/lib/tclconst.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/tclconst.pir Mon Aug 1 21:24:40 2005
@@ -0,0 +1,87 @@
+.namespace [ "TclConst" ]
+
+.HLL "Tcl", "tcl_group"
+
+# return codes
+ .const int TCL_OK = 0
+ .const int TCL_ERROR = 1
+ .const int TCL_RETURN = 2
+ .const int TCL_BREAK = 3
+ .const int TCL_CONTINUE = 4
+
+=head2 __class_init
+
+Define the attributes required for the class.
+
+=cut
+
+.sub __class_init @LOAD
+ $P0 = getclass "TclString"
+ $P1 = subclass $P0, "TclConst"
+
+ $P0 = new Hash
+ $P0[ 97] = "\a"
+ $P0[ 98] = "\x8" # \b
+ $P0[102] = "\f"
+ $P0[110] = "\n"
+ $P0[114] = "\r"
+ $P0[116] = "\t"
+ $P0[118] = "\v"
+
+ store_global "_Tcl", "backslashes", $P0
+.end
+
+.sub __clone method
+ .local pmc obj
+ $I0 = typeof self
+ obj = new $I0
+ obj = self
+ .return(obj)
+.end
+
+.sub __set_string_native method
+ .param string value
+
+ .local pmc backslashes
+ find_global backslashes, "_Tcl", "backslashes"
+
+ .local int pos
+ pos = 0
+loop:
+ pos = index value, "\\", pos
+ if pos == -1 goto done
+
+ $I0 = pos + 1
+ $I0 = ord value, $I0
+ if $I0 == 111 goto octal # \o
+ $I1 = exists backslashes[$I0]
+ if $I1 goto special
+
+ substr value, pos, 1, ""
+ inc pos
+ goto loop
+
+octal:
+ goto loop
+
+special:
+ $S0 = backslashes[$I0]
+ substr value, pos, 2, $S0
+ inc pos
+ goto loop
+
+done:
+ $I0 = classoffset self, "TclConst"
+ $P0 = getattribute self, $I0
+ $P0 = value
+.end
+
+=head2 interpret
+
+Get the value of the const.
+
+=cut
+
+.sub interpret method
+ .return(TCL_OK, self)
+.end
\ No newline at end of file
Added: trunk/languages/tcl/lib/tclvar.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/tclvar.pir Mon Aug 1 21:24:40 2005
@@ -0,0 +1,34 @@
+.namespace [ "TclVar" ]
+
+.HLL "Tcl", "tcl_group"
+
+# return codes
+ .const int TCL_OK = 0
+ .const int TCL_ERROR = 1
+ .const int TCL_RETURN = 2
+ .const int TCL_BREAK = 3
+ .const int TCL_CONTINUE = 4
+
+=head2 __class_init
+
+Define the attributes required for the class.
+
+=cut
+
+.sub __class_init @LOAD
+ $P0 = getclass "TclConst"
+ $P1 = subclass $P0, "TclVar"
+.end
+
+=head2 interpret
+
+Get the value of the variable.
+
+=cut
+
+.sub interpret method
+ .local pmc read
+ read = find_global "_Tcl", "__read"
+ $S0 = self
+ .return read($S0)
+.end
\ No newline at end of file
Modified: trunk/languages/tcl/lib/tclword.pir
==============================================================================
--- trunk/languages/tcl/lib/tclword.pir (original)
+++ trunk/languages/tcl/lib/tclword.pir Mon Aug 1 21:24:40 2005
@@ -1,47 +1,18 @@
=head1 TclWord
-This object holds the result of parsing a tcl command. Internally,
-It represents a word as discrete chunks, which are either finalized
-or require interpolation. Each chunk is marked as such. When the
-word is I<used> (at interpretation or at execution time), the required
-interpolation occurs (either variable or command)
-
-=head1 Attributes
-
-Each TclWord has the following attributes:
-
-=head2 chunks
-
-an array of pairs of (type, content), where type/content is
-
-=over 4
-
-=item CONST
-
-a string
-
-=item VARIABLE
-
-an array suitable for passing to C<_Tcl::_get_var>
-
-=item COMMAND
-
-the result of a the parse step for a [] command, i.e.
-a TclList of TclWords.
-
-=back
-
-=head2 constant
-
-An Integer PMC flag representing whether or not the value we hold is
-constant. I<Used as a hint at compile time.>
-
=cut
.namespace [ "TclWord" ]
.HLL "Tcl", "tcl_group"
+# return codes
+ .const int TCL_OK = 0
+ .const int TCL_ERROR = 1
+ .const int TCL_RETURN = 2
+ .const int TCL_BREAK = 3
+ .const int TCL_CONTINUE = 4
+
=head1 Methods
TclWord defines the following methods:
@@ -53,506 +24,45 @@ Define the attributes required for the c
=cut
.sub __class_init @LOAD
- newclass $P1, "TclWord"
- addattribute $P1, "chunks"
- addattribute $P1, "constant"
+ $P0 = getclass "TclList"
+ $P1 = subclass $P0, "TclWord"
.end
-=head2 __init
+=head2 interpret
-Initialize the attributes for an instance of the class
+Return a PMC that contains the value of our word, concatenating
+the string values of the elements.
=cut
-.sub __init method
- .local pmc emptyArray
- .local pmc constant
-
- emptyArray = new TclList
-
- setattribute self, "TclWord\x00chunks", emptyArray
- constant = new Integer
- constant = 1
- setattribute self, "TclWord\x00constant", constant
-.end
-
-=head2 clone
-
-Clone a TclWord object.
-
-=cut
-
-.sub __clone method
- .local pmc chunks
- .local pmc constant
-
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
-
- chunks = clone chunks
- constant = clone constant
+.sub interpret method
+ .local pmc retval
+ .local int return_type
+ return_type = TCL_OK
- .local pmc value
- $I0 = typeof self
- value = new $I0
- setattribute value, "TclWord\x00chunks", chunks
- setattribute value, "TclWord\x00constant", constant
+ .local int i, len
+ i = 0
+ len = self
- .return(value)
-.end
-
-=head2 concat_words
-
-Given an array of words, append the chunks of a given word to the existing
word
-
-=cut
-
-.sub concat_words method
- .param pmc words
-
- .local pmc word
- .local pmc chunk
-
- .local pmc these_chunks,this_constant
- these_chunks = getattribute self, "TclWord\x00chunks"
- this_constant = getattribute self, "TclWord\x00constant"
-
- .local pmc those_chunks,that_constant
-
- .local int num_words
- .local int word_num
-
- .local int num_chunks
- .local int chunk_num
-
- num_words = words
- word_num = 0
-outer_loop:
- if word_num == num_words goto outer_loop_done
-
- word = words[word_num]
- those_chunks = getattribute word, "TclWord\x00chunks"
- that_constant = getattribute word, "TclWord\x00constant"
-
- num_chunks = those_chunks
- chunk_num = 0
-
- if that_constant goto inner_loop
- this_constant = 0
-
-inner_loop:
- if chunk_num == num_chunks goto inner_loop_done
-
- chunk = those_chunks[chunk_num]
- push these_chunks, chunk
- inc chunk_num
-
- goto inner_loop
-
-inner_loop_done:
- inc word_num
-
-outer_loop_done:
+ .local string word
+ word = ""
+loop:
+ if i == len goto loop_done
-
-.end
-
-=head2 concat_char
-
-Add a constant character to a TclWord
-
-=cut
-
-.sub concat_char method
- .param int arg
-
- .local pmc chunk
- .local pmc chunks
- .local string str
+ $P0 = self[i]
+ (return_type, retval) = $P0.interpret()
+ if return_type != TCL_OK goto done
+ $S0 = retval
+ word .= $S0
- str = chr arg
-
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 0
- chunk[1] = str
-
- chunks = getattribute self, "TclWord\x00chunks"
- push chunks, chunk
-.end
-
-=head2 concat_const
-
-Add a constant string to a TclWord
-
-=cut
-
-.sub concat_const method
- .param string arg
-
- .local pmc chunk
- .local pmc chunks
-
- if arg == "" goto end
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 0
- chunk[1] = arg
-
- chunks = getattribute self, "TclWord\x00chunks"
- push chunks, chunk
-end:
-.end
-
-
-=head2 concat_variable
-
-Add the name of a variable to be interpolated to a TclWord. Takes the name
-of the var, and an optional index for array variables.
-
-=cut
-
-.sub concat_variable method
- .param string var
- .param string idx
-
- .local pmc chunk
- .local pmc chunks
- .local pmc constant
-
- chunk = new ResizablePMCArray
- chunk[0] = 1
- chunk[1] = var
-
- # I2 == # string params.
- if I2 == 1 goto no_index
- chunk[2] = idx
-
-no_index:
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
- constant = 0
- push chunks, chunk
-.end
-
-=head2 concat_command
-
-Add a command to be interpolated to a TclWord. Takes the
-text of the command, and stores the parsed version for
-later interpretation.
-
-=cut
-
-.sub concat_command method
- .param string cmd
-
- .local pmc chunk,chunks,parsed_cmd,constant
-
- .local pmc parser
- parser = find_global "_Tcl", "parser"
- parsed_cmd = parser."parse"(cmd,0,0)
- register parsed_cmd
-
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 2
- chunk[1] = parsed_cmd
-
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
- constant = 0
- push chunks, chunk
-.end
-
-=head2 __get_pmc
-
-Return a PMC that contains the value of our word. If we're just a command,
-evaluate the command and return the resulting PMC. If we're just a variable,
-return the PMC associated with that variable. In any other case, concat
-the results and return a Stringy PMC.
-
-=cut
-
-.sub __get_pmc method
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local int count
- count = chunks
-
- if count == 1 goto justpmc
- ($I0,$S0) = self.__get_string()
- $P0 = new String
- $P0 = $S0
- .return($I0,$P0)
-
-justpmc:
- .local pmc chunk
- chunk = chunks[0]
- .local int chunk_type
- chunk_type = chunk[0]
- .local pmc chunk_value
- chunk_value = chunk[1]
-
- if chunk_type == 0 goto constant
- if chunk_type == 1 goto variable
-
-command:
- .local pmc interpret
- interpret = find_global "_Tcl", "__interpret"
- ($I0,$P0) = interpret(chunk_value)
- .return($I0,$P0)
-
-constant:
- # 0 == TCL_OK
- .return(0,chunk_value)
-
-variable:
- .local pmc read
- read = find_global "_Tcl", "__read"
- .local pmc get_var
- get_var = find_global "_Tcl", "__get_var"
- .local int return_type
- $S1 = chunk_value
- $S2 = chunk[2]
- if $S2 == "" goto get_variable
- .return get_var($S1,$S2)
-get_variable:
- .return read($S1)
-.end
-
-=head2 __get_string
-
-Stringify - In our case, we take the individual chunks of the words and
-evaluate them - so if we have a TclWord that came from a string like:
-
- "$a + $b = [expr $a + $b]"
-
-We have split it up internally to look like:
-
- VAR: a
- CONST: " + "
- VAR: b
- CONST: " = "
- COMMAND:
- WORD:
- CONST: "expr"
- WORD:
- VAR: a
- WORD:
- CONST: "+"
- WORD:
- VAR: b
-
-And, when we ask for the string representation, the two variable interpolations
-are performed, and the command containing "expr" is also evaluated. The
-resulting string, (assuming values of 1 and 2 for a and b, respectively) is
-
- "1 + 2 = 3"
-
-NB: This isn't quite the normal C<__get_string> method, and should probably be
-renamed - it is returning a tcl exit code in addition to the normal string
-result.
-
-=cut
-
-.sub __get_string method
-
- .local int return_type
-
- return_type = 0
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local pmc interpret
- .local pmc get_var
-
- interpret = find_global "_Tcl", "__interpret"
- get_var = find_global "_Tcl", "__get_var"
-
- .local string retval
- retval = ""
-
- $I1 = chunks
- $P11 = new Integer
- $P11 = 0 # XXX If we don't use a PMC, this value is discarded because of
- # a method call below.
-loop:
- $I0 = $P11
- if $I0 == $I1 goto loop_done
- $P0 = chunks[$I0]
- $I2 = $P0[0]
-
- if $I2 == 0 goto constant
- if $I2 == 1 goto variable
- if $I2 == 2 goto command
-
-command:
- $P1 = $P0[1]
- $S1 = typeof $P1
- ($I0, $P9) = interpret( $P1 )
- $S0 = $P9
- if $I0 == 0 goto loop_next
- # else, an exception value was returned. abort.
- return_type = $I0
- goto loop_done
-
-variable:
- $S1 = $P0[1]
- $S2 = $P0[2]
- if $S2 == "" goto get_variable
- ($I2,$P9) = get_var($S1,$S2)
- goto got_variable
-
-get_variable:
- ($I2,$P9) = get_var($S1)
- $S0 = $P9
-
-got_variable:
- if $I2 == 0 goto loop_next
- return_type = $I2
- retval = $S0
- goto loop_done
-
-constant:
- $S0 = $P0[1]
- # goto loop_next
-
-loop_next:
- retval .= $S0
- $P11 = $P11 + 1
- goto loop
-
-loop_done:
- .return(return_type,retval)
-.end
-
-=head2 __dump
-
-Allow us to be rendered by Data::Dumper
-
-Not tested, uses pmcPerlArray dumper method because of the way Dumper is
written.
-Shouldn't have to.
-
-=cut
-
-.sub __dump method
- .param pmc dumper
- .param string name
-
- .local string subindent
- .local string indent
- (subindent, indent) = dumper."newIndent"()
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local int num_chunks
- num_chunks = chunks
- .local int chunk_num
- chunk_num = 0
-
- print "(size:"
- print num_chunks
- print ") {\n"
-
-loop:
- if chunk_num >= num_chunks goto loop_done
- if chunk_num == 0 goto skip
- print ",\n"
-skip:
-
- $P0 = chunks[chunk_num]
- $I0 = $P0[0]
-
- print subindent
-
- if $I0 == 2 goto command
- if $I0 == 1 goto var
-
- $S0 = $P0[1]
- print "\""
- print $S0
- print "\""
- goto loop_next
-
-command:
- $P1 = $P0[1]
- # XXX This will need to change.
- dumper.pmcPerlArray($P1)
- goto loop_next
-
-var:
- $S0 = $P0[1]
- $S1 = $P0[2]
- if $S1 != "" goto array_var
- print "[ set "
- print $S0
- print " ]"
- goto loop_next
-
-array_var:
- print "[ set "
- print $S0
- print " ("
- print $S1
- print ") ]"
-
-loop_next:
- inc chunk_num
+ inc i
goto loop
loop_done:
- print "\n"
-
- print indent
- print "}"
-
- dumper."deleteIndent"()
-.end
-
-=head2 __get_integer
-
-Return the number of chunks in this tclword.
-
-=cut
-
-.sub __get_integer method
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
- .local int size
- size = chunks
-
- .return(size)
-.end
-
-=head2 XXX __freeze
-
-Not implemented yet, pending delegation of C<freeze> to objects.
-(Necessary anymore?)
-
-=head2 XXX __thaw
-
-Not implemented yet, pending delegation of C<thaw> to objects.
-(Necessary anymore?)
-
-=cut
-
-=head2 __is_const
-
-Returns an integer, C<1> if this word is constant, C<0> if it requires
-interpolation.
-
-=cut
+ retval = new TclString
+ retval = word
-.sub __is_const method
- .local pmc constant
- constant = getattribute self, "TclWord\x00constant"
- .local int result
- result = constant
- .return(result)
+done:
+ .return(return_type, retval)
.end
Modified: trunk/languages/tcl/t/tcl_command_subst.t
==============================================================================
--- trunk/languages/tcl/t/tcl_command_subst.t (original)
+++ trunk/languages/tcl/t/tcl_command_subst.t Mon Aug 1 21:24:40 2005
@@ -4,7 +4,6 @@ use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
use Parrot::Test tests => 10;
use Test::More;
-use vars qw($TODO);
language_output_is("tcl",<<'TCL', <<'OUT',"all");
set a 5
@@ -68,13 +67,9 @@ TCL
2
OUT
-TODO: {
-$TODO = "bugs";
-
language_output_is("tcl",<<'TCL',<<'OUT',"] in \"\"s");
puts [set a "]"]
TCL
]
OUT
-}
Modified: trunk/languages/tcl/tcl.pir
==============================================================================
--- trunk/languages/tcl/tcl.pir (original)
+++ trunk/languages/tcl/tcl.pir Mon Aug 1 21:24:40 2005
@@ -36,8 +36,8 @@
STDIN = getstdin
STDOUT = getstdout
- .local pmc parser,interpret
- parser = find_global "_Tcl", "parser"
+ .local pmc parse,interpret
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
input_loop:
@@ -45,7 +45,7 @@ input_loop:
STDOUT."flush"()
input_line = readline STDIN
unless STDIN goto done
- $P1 = parser."parse"(input_line,0,0)
+ $P1 = parse(input_line)
register $P1
(retcode,retval) = interpret($P1)
# print out the result of the evaluation.
Modified: trunk/languages/tcl/tcl.pir_template
==============================================================================
--- trunk/languages/tcl/tcl.pir_template (original)
+++ trunk/languages/tcl/tcl.pir_template Mon Aug 1 21:24:40 2005
@@ -83,6 +83,9 @@ providing a compreg-compatible method.
.sub __prepare_lib @LOAD,@ANON
# Load any dependant libraries.
+ load_bytecode "languages/tcl/lib/tclcommand.pbc"
+ load_bytecode "languages/tcl/lib/tclconst.pbc"
+ load_bytecode "languages/tcl/lib/tclvar.pbc"
load_bytecode "languages/tcl/lib/tclword.pbc"
load_bytecode "library/Data/Escape.pbc"
load_bytecode "library/PGE.pbc"
@@ -157,12 +160,6 @@ providing a compreg-compatible method.
store_global "_Tcl", "functions", math_funcs
store_global "_Tcl", "precedence", precedence
- # Grab a (for now) global instance of TclParser
- .local pmc parser
- parser = new TclParser
-
- store_global "_Tcl", "parser", parser
-
# Eventually, we'll need to register MMD for the various Tcl PMCs
# (Presuming we don't do this from the .pmc definitions.)
@@ -242,8 +239,10 @@ providing a compreg-compatible method.
pir_code .= " @ANON\n.local string code\ncode = \""
tcl_code = escaper(tcl_code,"\"")
pir_code .= tcl_code
- pir_code .= "\"\n.local pmc parser\n.local pmc tcl_interpret\nparser = new
TclParser"
- pir_code .= "\ntcl_interpret = find_global \"_Tcl\", \"__interpret\"\n$P1 =
parser.\"parse\"(code,0,0)\n.return tcl_interpret($P1)\n.end\n"
+ pir_code .= "\"\n.local pmc tcl_interpret\n.local pmc parse\n"
+ pir_code .= "tcl_interpret = find_global \"_Tcl\", \"__interpret\"\n"
+ pir_code .= "parse = find_global \"_Tcl\", \"parse\"\n"
+ pir_code .= "$P1 = parse(code)\n.return tcl_interpret($P1)\n.end\n"
$P1 = compile pir_compiler, pir_code
.return ($P1)
Modified: trunk/languages/tcl/tcl.pl
==============================================================================
--- trunk/languages/tcl/tcl.pl (original)
+++ trunk/languages/tcl/tcl.pl Mon Aug 1 21:24:40 2005
@@ -33,7 +33,7 @@ my @commands = grep {s/\.pir$//} @cmd_fi
my $lib_dir = "lib";
opendir(LIBDIR,$lib_dir) or die;
-my @libs = map {"$lib_dir/$_"} grep {m/\.pir$/} grep {!
m/^tcl(lib|word).pir$/} readdir(LIBDIR);
+my @libs = map {"$lib_dir/$_"} grep {m/\.pir$/} grep {!
m/^tcl(lib|command|const|var|word).pir$/} readdir(LIBDIR);
closedir(LIBDIR);
my $includes;
