Author: coke
Date: Wed Sep 28 16:52:37 2005
New Revision: 9269
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/tcl.in
trunk/languages/tcl/TODO
trunk/languages/tcl/docs/hacks.pod
trunk/languages/tcl/lib/commands/expr.pir
trunk/languages/tcl/lib/commands/for.pir
trunk/languages/tcl/lib/commands/if.pir
trunk/languages/tcl/lib/commands/while.pir
trunk/languages/tcl/lib/expression.pir
trunk/languages/tcl/lib/parser.pir
trunk/languages/tcl/lib/tclcommand.pir
trunk/languages/tcl/lib/tclconst.pir
trunk/languages/tcl/lib/tclfunc.pir
trunk/languages/tcl/lib/tclops.pir
trunk/languages/tcl/lib/tclvar.pir
trunk/languages/tcl/t/cmd_expr.t
trunk/languages/tcl/t/tcl_misc.t
trunk/languages/tcl/tcl.pir_template
trunk/languages/tcl/tcl.pl
Log:
Convert tcl's [expr] to be a compiler.
Now, to evaluate an expression, first call expression_parse(), which returns an
executable .Sub.
to get the value of the expression at a later time, simply invoke that sub.
Remove unecessary "interpret" code from various lib classes. (Adding "compile"
methods). Additionally,
remove the AST that was used by exp_parse to hand to exp_compile - now compile
is handed a single
object which has as attributes the appropriate objects.
All tests pass.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Wed Sep 28 16:52:37 2005
@@ -1458,6 +1458,7 @@ languages/tcl/lib/parser.pir
languages/tcl/lib/returncodes.pir [tcl]
languages/tcl/lib/string_to_list.pir [tcl]
languages/tcl/lib/string.pir [tcl]
+languages/tcl/lib/tclbinaryops.pir [tcl]
languages/tcl/lib/tclcommand.pir [tcl]
languages/tcl/lib/tclcommandlist.pir [tcl]
languages/tcl/lib/tclconst.pir [tcl]
Modified: trunk/config/gen/makefiles/tcl.in
==============================================================================
--- trunk/config/gen/makefiles/tcl.in (original)
+++ trunk/config/gen/makefiles/tcl.in Wed Sep 28 16:52:37 2005
@@ -77,7 +77,7 @@ lib${slash}variables.pir \
tcl.pir_template \
tcl.pl
-tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclcommand.pbc
lib${slash}tclcommandlist.pbc lib${slash}tclconst.pbc lib${slash}tclfunc.pbc
lib${slash}tclops.pbc lib${slash}tclvar.pbc lib${slash}tclword.pbc tcl.pir
+tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclbinaryops.pbc
lib${slash}tclcommand.pbc lib${slash}tclcommandlist.pbc lib${slash}tclconst.pbc
lib${slash}tclfunc.pbc lib${slash}tclops.pbc lib${slash}tclvar.pbc
lib${slash}tclword.pbc tcl.pir
$(PARROT) --output=tcl.pbc tcl.pir
pmcs:
@@ -95,6 +95,9 @@ 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}tclbinaryops.pbc: lib${slash}tclbinaryops.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclbinaryops.pbc
$(LIBPATH)${slash}tclbinaryops.pir
+
lib${slash}tclcommand.pbc: lib${slash}tclcommand.pir
$(PARROT) --output=$(LIBPATH)${slash}tclcommand.pbc
$(LIBPATH)${slash}tclcommand.pir
Modified: trunk/languages/tcl/TODO
==============================================================================
--- trunk/languages/tcl/TODO (original)
+++ trunk/languages/tcl/TODO Wed Sep 28 16:52:37 2005
@@ -61,18 +61,8 @@ Perhaps via [namespace import]? Can fake
=item [expr]
-the expr AST could use a rework. Be nice if it just passed around something
-invokable.
-
-clean up expr so that it's not passing around
-type indicators. - just use PMCs everywhere. (Though we may still need
-to have CONST vs. VARIABLE types.)
-
-The type indicator is also used to disambiguate operators and function calls
-from operands. We can easily remove it for operands, but how to cleanly
-remove this for operators?
-
-TBD: blocks and strings as operands
+Add "is_const" global which checks to see if something is, in fact,
+constant. (which will allow us to then constant fold)
TBD: ternary op
Modified: trunk/languages/tcl/docs/hacks.pod
==============================================================================
--- trunk/languages/tcl/docs/hacks.pod (original)
+++ trunk/languages/tcl/docs/hacks.pod Wed Sep 28 16:52:37 2005
@@ -80,8 +80,6 @@ actual commands and variables. I think t
and, if any other languages support this feature, this would give us a chance
to interoperate.
-=back
-
=item list splicing
There are several cases where we convert TclLists or ResizablePMCArrays to
@@ -89,6 +87,16 @@ Arrays so that we can use the splice opc
support in parrot array classes, as well as our own.
L<lib/commands/linsert.pir>
+=item marshalling/unmarshalling
+
+When compiling, there is currently no easy way to embed a PMC that exists
+at runtime into the compiled code. Because of this, we have to interrogate
+the PMC at compile time for its type, and then handroll the appropriate PIR
+to intialize it's value. We should be able to freeze the PMC during
compilation,
+And then have in the generated code C<$P1 = thaw "...">.
+
+=back
+
=cut
Modified: trunk/languages/tcl/lib/commands/expr.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/expr.pir (original)
+++ trunk/languages/tcl/lib/commands/expr.pir Wed Sep 28 16:52:37 2005
@@ -17,7 +17,6 @@
.local pmc expression_p
.local pmc expression_i
expression_p = find_global "_Tcl", "__expression_parse"
- expression_i = find_global "_Tcl", "__expression_interpret"
expr = ""
looper = 0
@@ -35,8 +34,8 @@ loop:
goto loop
loop_done:
- retval = expression_p(expr)
- .return expression_i(retval)
+ $P1 = expression_p(expr)
+ .return $P1()
no_args:
.throw("wrong # args: should be \"expr arg ?arg ...?\"")
Modified: trunk/languages/tcl/lib/commands/for.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/for.pir (original)
+++ trunk/languages/tcl/lib/commands/for.pir Wed Sep 28 16:52:37 2005
@@ -17,14 +17,13 @@
next_code = argv[2]
body_code = argv[3]
- .local pmc start_parsed, next_parsed, body_parsed, test_parsed
+ .local pmc start_parsed, next_parsed, body_parsed, test_compiled
.local pmc retval
.local pmc parse
- .local pmc expression_p, expression_i
+ .local pmc expression_p
parse = find_global "_Tcl", "parse"
expression_p = find_global "_Tcl", "__expression_parse"
- expression_i = find_global "_Tcl", "__expression_interpret"
# Parse the bits that are code.
start_parsed = parse(start_code)
@@ -44,8 +43,8 @@ continue:
# then execute next
next_parsed."interpret"()
# then check condition
- test_parsed = expression_p(test_code)
- retval = expression_i(test_parsed)
+ test_compiled = expression_p(test_code)
+ retval = test_compiled()
if retval goto for_loop
.return ("")
Modified: trunk/languages/tcl/lib/commands/if.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/if.pir (original)
+++ trunk/languages/tcl/lib/commands/if.pir Wed Sep 28 16:52:37 2005
@@ -23,10 +23,9 @@
.local int counter
.local pmc parse
- .local pmc expression_p,expression_i
+ .local pmc expression_p
parse = find_global "_Tcl", "parse"
expression_p = find_global "_Tcl", "__expression_parse"
- expression_i = find_global "_Tcl", "__expression_interpret"
.local string temp_str
temp_str =""
@@ -73,8 +72,8 @@ get_final:
if counter != argc goto more_than_else
begin_parsing:
- retval = expression_p(condition)
- retval = expression_i(retval)
+ $P1 = expression_p(condition)
+ retval = $P1()
unless retval goto do_elseifs
code = body
@@ -88,8 +87,8 @@ elseif_loop:
if $I2 == $I1 goto do_else
$P1 = elseifs[$I2]
condition = $P1[0]
- retval = expression_p(condition)
- retval = expression_i(retval)
+ $P2 = expression_p(condition)
+ retval = $P2()
if retval goto done_elseifs
inc $I2
goto elseif_loop
Modified: trunk/languages/tcl/lib/commands/while.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/while.pir (original)
+++ trunk/languages/tcl/lib/commands/while.pir Wed Sep 28 16:52:37 2005
@@ -10,29 +10,23 @@
if argc != 2 goto bad_args
- .local pmc cond_p
- cond_p = argv[0]
- .local string body_p
- body_p = argv[1]
+ .local string condition,body
+ condition = argv[0]
+ body = argv[1]
.local pmc retval, parsed_code
.local pmc parse
- .local pmc expression_p
- .local pmc expression_i
+ .local pmc expression_p, compiled_condition
parse = find_global "_Tcl", "parse"
expression_p = find_global "_Tcl", "__expression_parse"
- expression_i = find_global "_Tcl", "__expression_interpret"
- $S0 = body_p
- parsed_code = parse($S0)
- register parsed_code
+ parsed_code = parse(body)
+ compiled_condition = expression_p(condition)
while_loop:
- $S0 = cond_p
- retval = expression_p($S0)
- retval = expression_i(retval)
+ retval = compiled_condition()
unless retval goto done
push_eh handle_continue
retval = parsed_code."interpret"()
Modified: trunk/languages/tcl/lib/expression.pir
==============================================================================
--- trunk/languages/tcl/lib/expression.pir (original)
+++ trunk/languages/tcl/lib/expression.pir Wed Sep 28 16:52:37 2005
@@ -1,25 +1,23 @@
-.macro __pop_value_from_expr_stack(STACK,VALUE)
- .VALUE = pop .STACK
- .VALUE = .VALUE[1]
- .VALUE = .VALUE."interpret"()
- .VALUE = __number(.VALUE) # XXX unnecessary ?
-.endm
-
.namespace [ "_Tcl" ]
+.const int MAX_PRECEDENCE = 11
+
=head1 _Tcl::__expression_parse
-Given a string (or String), return a single stack that contains the work to be
-done. This stack can then be passed to C<__expression_interpret> to actually
-invoke the items on the stack.
+Given a string, return an invokable PMC that will generate the appropriate
+value described by this Tcl expression. An intermediate AST is generated,
+and the functions ends with a tailcall to the compiler.
=cut
-.const int MAX_PRECEDENCE = 11
-
.sub __expression_parse
.param string expr
+ $P1 = __expression_ast(expr)
+ .return __expression_compile($P1)
+.end
+.sub __expression_ast
+ .param string expr
.local pmc retval
.local pmc undef
@@ -40,11 +38,10 @@ operand:
chunk[0] = OPERAND
chunk[1] = retval
push chunks, chunk
-
goto operator
no_operand:
- .throw ("no operand!")
+ .throw ("XXX: no operand!")
operator:
(chunk, pos) = get_operator(expr, pos)
@@ -52,89 +49,103 @@ operator:
push chunks, chunk
goto operand
- # if we don't match any of the possible cases so far, then we must
- # be a string operand, but for now, die. #XXX
-
chunks_done:
-# convert the chunks into a stack.
- # to do this, we scan for our Operators in precedence order.
- # as we find each one, put it on the program_stack with the appropriate
- # args. Leave a "NOOP" placeholder when pulling things. If our target
- # arg is a noop, we can either put it on the stack and ignore it when
- # popping the stack, or not put it on the stack.
+=for comment
- # XXX cheat for now , assume no precedence. means we can just
- # walk through, grabbing ops. (hope nothing is orphaned?)
+Convert the chunks into a stack. For each level of precendence,
+scan the chunk list for operators that match our level. As we find one,
+grab the left and right operands. If the operand is null, instead use
+the value from the same location in the program stack as the operand (as it
+is the result of a previous operator.). If a value is pulled from the
+program_stack, then null it there.
+
+Now that we have an operand and two operators (unary ops are treated like
+operands during the parse phase. Ternary op is currently ignored, but we'd
+special case it here.), create a TclBinaryOp, and put it in the same
+index in the program stack as the left op here. Replace all three entries
+in the chunk list with a single NULL entry.
+
+When our list of chunks to process is a single NULL entry, we're done,
+and now have a program list containing a single element, which is something
+which supports C<compile>. (In most cases, a TclBinaryOp)
- .local int stack_index
- .local int input_len
+=cut
+ .local int stack_index
stack_index = 0
- # we're looping over this once - to handle precedence, I suggest
- # looping multiple times, leaving the NOOPS when we remove something
- # to faciliate processing on further runs. If we try to pull a
- # left or right arg and see a NO-OP, we know it's safe to skip because
- # walking the stack will convert it to a number by the time we get to it.
-
- .local pmc our_op
- input_len = chunks
- if input_len == 0 goto die_horribly
-
- # a single value, return now.
- if input_len != 1 goto pre_converter_loop
- # XXX (That's value, not an operator)
- .return(chunks)
+ .local int input_len
+ input_len = chunks
+ if input_len == 1 goto singleton_chunk
-pre_converter_loop:
.local int precedence_level
- precedence_level = -1 # start with functions
+ precedence_level = 1
+ .local pmc operand1, operand2, our_op
+
converter_loop:
+ input_len = chunks
+
if precedence_level > MAX_PRECEDENCE goto converter_done
- if stack_index >= input_len goto precedence_done
+ if input_len == 1 goto converter_done # only one item left. should be null
+ if stack_index >= input_len goto precedence_done
+
our_op = chunks[stack_index]
- if_null our_op, converter_next
- $I0 = typeof our_op
- if $I0 == .Undef goto converter_next
+ unless our_op, converter_next # skip placeholders
+ $I0 = defined our_op
+ unless $I0, converter_next # skip placeholders (redundant?)
$I2 = our_op[0]
if $I2 == OPERAND goto converter_next
- if $I2 == CHUNK goto converter_next
- if $I2 == OP goto is_opfunc
-
- # Should never be reached (XXX then shouldn't we die horribly?)
- goto converter_next
-is_opfunc:
+# an_operator
$I3 = our_op[2]
- if $I3 != precedence_level goto converter_next
+ if $I3 != precedence_level goto converter_next
+
+# right precedence level.
right_arg:
$I2 = stack_index + 1
- if $I2 >= input_len goto left_arg
- retval = chunks[$I2]
- if_null retval, left_arg
- chunks[$I2] = undef
- inc $I4
- program_stack = unshift retval
-
- # If we're a function, (XXX) assume a single arg (which
- # we've now pulled - so, go to the, skip the left arg.
- if precedence_level == -1 goto shift_op
+ ### XXX Should never occur? if $I2 >= input_len goto left_arg
+ $P1 = chunks[$I2]
+ unless $P1, right_arg_precalc
+ operand2 = $P1[1]
+ goto left_arg
+
+right_arg_precalc:
+ operand2 = program_stack[$I2]
+ program_stack[$I2] = $P1
- # XXX we just deal with binary args at the moment.
left_arg:
$I2 = stack_index - 1
- if $I2 < 0 goto shift_op
- retval = chunks[$I2]
- if_null retval, shift_op
- chunks[$I2] = undef
- inc $I4
- program_stack = unshift retval
+ ### XXX Should never occur? if $I2 < 0 goto shift_op
+ $P1 = chunks[$I2]
+ unless $P1, left_arg_precalc
+ operand1 = $P1[1]
+ goto shift_op
+
+left_arg_precalc:
+ operand1 = program_stack[$I2]
+ program_stack[$I2] = $P1
shift_op:
- program_stack = unshift our_op
- chunks[stack_index] = undef
+ .local pmc type
+ type = our_op[1]
+ $I0 = find_type "TclBinaryOp" # XXX should cache this?
+ .local pmc binary_op
+ binary_op = new $I0
+
+
+ setattribute binary_op, "TclBinaryOp\x00type", type
+ setattribute binary_op, "TclBinaryOp\x00l_operand", operand1
+ setattribute binary_op, "TclBinaryOp\x00r_operand", operand2
+
+ program_stack[$I2] = binary_op
+
+ delete chunks[$I2] # delete the left arg.
+ chunks[$I2] = 0 # zero the operator
+ inc $I2 # skip the operator position
+ delete chunks[$I2] # delete the right arg.
+ dec stack_index
converter_next:
inc stack_index
@@ -145,11 +156,18 @@ precedence_done:
stack_index = 0
goto converter_loop
+singleton_chunk:
+ # a single value, return now.
+ $P1 = chunks[0] # first element..
+ $P1 = $P1[1] # value of first element.
+ .return ($P1)
+
die_horribly:
- .throw ("XXX: An error occurred in [expr]")
+ .throw ("XXX: An error occurred parsing [expr]")
converter_done:
- .return(program_stack)
+ $P1 = program_stack[0]
+ .return ($P1)
.end
@@ -278,228 +296,6 @@ done:
.return(chunk, pos)
.end
-.sub __expression_interpret
- .param pmc program_stack
-
- .local pmc result_stack
- result_stack = new TclList
- .local pmc retval
-stack_evaluator:
- # while the prog stack exists:
- .local int size
- size = program_stack
- if size == 0 goto stack_done
-
- .local int type
- .local pmc chunk
- chunk = pop program_stack
- $I10 = typeof chunk
- if $I10 == .Undef goto stack_evaluator
- type = chunk[0]
-
- # move all non op non funcs to the value stack
- if type == OP goto do_op
- push result_stack, chunk
- goto stack_evaluator
-
-do_op:
- # right now, we assume binary ops. Later, each op will define the
- # number of and type of ops it takes, and we will respect it.
-
- .local int op
- op = chunk[1]
-
- # XXX assume all operands take two args.
- # XXX looks like there is code to convert everything to numbers.
- # - this will have to be changed for string ops.
-
- .local pmc r_arg,l_arg,op_result
- op_result = new TclInt
-
- # Is there a more efficient way to do this dispatch?
- if op == OPERATOR_MUL goto op_mul
- if op == OPERATOR_DIV goto op_div
- if op == OPERATOR_MOD goto op_mod
- if op == OPERATOR_PLUS goto op_plus
- if op == OPERATOR_MINUS goto op_minus
- if op == OPERATOR_SHL goto op_shl
- if op == OPERATOR_SHR goto op_shr
- if op == OPERATOR_LT goto op_lt
- if op == OPERATOR_GT goto op_gt
- if op == OPERATOR_LTE goto op_lte
- if op == OPERATOR_GTE goto op_gte
- if op == OPERATOR_EQUAL goto op_equal
- if op == OPERATOR_UNEQUAL goto op_unequal
- if op == OPERATOR_BITAND goto op_bitand
- if op == OPERATOR_BITXOR goto op_bitxor
- if op == OPERATOR_BITOR goto op_bitor
- if op == OPERATOR_NE goto op_ne
- if op == OPERATOR_EQ goto op_eq
- if op == OPERATOR_AND goto op_and
- if op == OPERATOR_OR goto op_or
-
- goto die_horribly # XXX should never happen, of course.
-
-op_mul:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = mul l_arg, r_arg
- goto done_op
-op_div:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = div l_arg, r_arg
- goto done_op
-op_mod:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = mod l_arg, r_arg
- goto done_op
-op_plus:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = l_arg + r_arg
- goto done_op
-op_minus:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = l_arg - r_arg
- goto done_op
-op_shl:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = shl l_arg, r_arg
- goto done_op
-op_shr:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = shr l_arg, r_arg
- goto done_op
-op_lt:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg < r_arg goto done_op
- op_result = 0
- goto done_op
-op_gt:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg > r_arg goto done_op
- op_result = 0
- goto done_op
-op_lte:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg <= r_arg goto done_op
- op_result = 0
- goto done_op
-op_gte:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg >= r_arg goto done_op
- op_result = 0
- goto done_op
-op_equal:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg == r_arg goto done_op
- op_result = 0
- goto done_op
-op_unequal:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- if l_arg != r_arg goto done_op
- op_result = 0
- goto done_op
-op_bitand:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = band l_arg, r_arg
- goto done_op
-op_bitxor:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = bxor l_arg, r_arg
- goto done_op
-op_bitor:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = bor l_arg, r_arg
- goto done_op
-op_ne:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- $S0 = l_arg
- $S1 = r_arg
- if $S0 != $S1 goto done_op
- op_result = 0
- goto done_op
-op_eq:
- .__pop_value_from_expr_stack(result_stack,l_arg)
- .__pop_value_from_expr_stack(result_stack,r_arg)
- op_result = 1
- $S0 = l_arg
- $S1 = r_arg
- if $S0 == $S1 goto done_op
- op_result = 0
- goto done_op
-op_and:
- op_result = 0
- .__pop_value_from_expr_stack(result_stack,l_arg)
- unless l_arg goto done_op
- .__pop_value_from_expr_stack(result_stack,r_arg)
- unless r_arg goto done_op
- op_result = 1
- goto done_op
-op_or:
- op_result = 1
- .__pop_value_from_expr_stack(result_stack,l_arg)
- if l_arg goto done_op
- .__pop_value_from_expr_stack(result_stack,r_arg)
- if r_arg goto done_op
- op_result = 0
- # goto done_op
-
-done_op:
- $P5 = new TclList
- $P5[0] = OPERAND
- $P5[1] = op_result
- push result_stack, $P5
-
- # Ignoring exceptions for now.
- goto stack_evaluator
-
-stack_done:
- $I0 = result_stack
- if $I0 == 0 goto die_horribly
- retval = pop result_stack
- goto evaluation_done
-
-die_horribly:
- .throw ("XXX: an error occurred in [expr]")
-
-evaluation_done:
- retval = retval[1]
-
- # XXX This is a bit of a hack. We should insure that everything we get at
this
- # point is either interpret-able or not.
-
- $I0 = can retval, "interpret"
- if $I0 goto done_interp
- .return (retval)
-
-done_interp:
- .return retval."interpret"()
-
-.end
-
.sub get_subexpr
.param string expr
.param int pos
@@ -534,14 +330,11 @@ paren_done:
inc pos
$S1 = substr expr, start, $I0
- # XXX this is now officially braindead. Fissit.
- retval = __expression_parse($S1)
- retval = __expression_interpret(retval)
-
+ retval = __expression_ast($S1)
.return(retval, pos)
die_horribly:
- .throw("XXX: An error occurred in EXPR")
+ .throw("XXX: An error occurred processing a sub-expression")
premature_end:
$S0 = "syntax error in expression \""
@@ -666,7 +459,7 @@ loop_done:
$I0 = pos - paren_pos
$S1 = substr expr, paren_pos, $I0
- operand = __expression_parse($S1)
+ operand = __expression_ast($S1)
setattribute func, "TclFunc\x00argument", operand
done:
@@ -711,3 +504,42 @@ unknown_func:
.return(unary, pos)
.end
+=head1 _Tcl::__expression_compile
+
+Given the AST generated by the expression parser, render the various operands
+as PIR.
+
+=cut
+
+.sub __expression_compile
+ .param pmc thing
+
+ .local pmc compile
+ compile = find_global "_Tcl", "compile"
+ .local string pir_code
+
+ ($I0,pir_code) = compile(thing,0)
+
+ .local pmc pir_compiler
+ pir_compiler = compreg "PIR"
+ # XXX deal with re-using sub name?
+
+ $P1 = new .Array
+ $P1 = 2
+ $P1[0] = pir_code
+ $P1[1] = $I0
+
+ # Use n_operators pragma to force generation of new pmcs
+ sprintf pir_code, ".pragma n_operators 1\n.sub blah @ANON\n%s.return
($P%s)\n.end\n", $P1
+
+ #print pir_code # for debugging the compiler
+
+ # XXX HACK: can't tailcall these.
+ $P1 = pir_compiler(pir_code)
+ .return ($P1)
+
+die_horribly:
+ .throw ("XXX: an error occurred compiling [expr]")
+
+.end
+
Modified: trunk/languages/tcl/lib/parser.pir
==============================================================================
--- trunk/languages/tcl/lib/parser.pir (original)
+++ trunk/languages/tcl/lib/parser.pir Wed Sep 28 16:52:37 2005
@@ -163,7 +163,7 @@ get:
$I0 = find_type "TclCommand"
command = new $I0
setattribute command, "TclCommand\x00name", word
-
+
next_word:
(word, pos) = get_word(tcl_code, chars, pos)
if_null word, done
@@ -493,13 +493,13 @@ Parses a subcommand and returns a TclCom
.param string tcl_code
.param int pos
inc pos
-
+
.local pmc command
.local pmc chars
chars = new Hash
chars[93] = 1 # ]
chars[59] = 1 # ;
-
+
(command, pos) = get_command(tcl_code, chars, pos)
dec pos
$I0 = ord tcl_code, pos
@@ -609,6 +609,53 @@ done:
.return($P0, pos)
.end
+
+=item C<(int reg_num, str code) = compile(pmc thing, int reg_num)>
+
+Given an object, call its compile method, or assume it's constant
+and generate the code for it.
+
+=cut
+
+.sub compile
+ .param pmc thing
+ .param int register_num
+
+ .local string pir_code
+
+ $I0 = can thing, "compile"
+
+ if $I0 goto can_compile
+
+ .local string thing_type,quote_char
+ thing_type = typeof thing
+ quote_char = ""
+ if thing_type == "TclString" goto stringish
+ if thing_type == "String" goto stringish
+ goto set_args
+stringish:
+ quote_char = "\""
+set_args:
+
+ .local pmc printf_args
+ printf_args = new .Array
+ printf_args = 6
+ printf_args[0] = register_num
+ printf_args[1] = thing_type
+ printf_args[2] = register_num
+ printf_args[3] = quote_char
+ printf_args[4] = thing
+ printf_args[5] = quote_char
+
+ pir_code = sprintf "$P%i = new .%s\n$P%i=%s%s%s\n", printf_args
+
+ .return(register_num,pir_code)
+
+can_compile:
+ .return thing."compile"(register_num)
+.end
+
=back
=cut
+
Modified: trunk/languages/tcl/lib/tclcommand.pir
==============================================================================
--- trunk/languages/tcl/lib/tclcommand.pir (original)
+++ trunk/languages/tcl/lib/tclcommand.pir Wed Sep 28 16:52:37 2005
@@ -23,10 +23,19 @@ Initialize the attributes for an instanc
=cut
.sub __init method
- $P0 = new TclString
- setattribute self, "TclCommand\x00name", $P0
+ #$P0 = new TclString
+ #setattribute self, "TclCommand\x00name", $P0
.end
+.sub __clone method
+ .local pmc obj
+ $I0 = typeof self
+ obj = new $I0
+ obj = self
+ .return(obj)
+.end
+
+
=head2 interpret
Execute the command.
@@ -90,3 +99,85 @@ no_command_non_interactive:
$S0 .= "\""
.throw($S0)
.end
+
+.sub compile method
+ .param int register_num
+
+ $P22 = getattribute self, "TclCommand\x00name"
+
+ .local pmc compile
+ compile = find_global "_Tcl", "compile"
+
+ .local string pir_code
+ pir_code = ""
+
+ .local string retval
+ # Generate partial code for each of our arguments
+ .local int ii, num_args, result_reg
+ num_args = self
+ ii = 0
+ .local pmc compiled_args
+ compiled_args = new .TclList
+arg_loop:
+ if ii == num_args goto arg_loop_done
+ $P1 = self[ii]
+ (result_reg,retval) = compile($P1,register_num)
+
+ push compiled_args, result_reg
+ register_num = result_reg + 1
+ pir_code .= retval
+ inc ii
+arg_loop_done:
+ # Generate code that will invoke our name'd command.
+ pir_code .= ".local pmc command,name\n"
+ # XXX Need to trap a missing command
+ # Need to actually compile our name, as it might not be constant.
+
+ .local pmc name
+ name = getattribute self, "TclCommand\x00name"
+ (register_num,retval) = compile(name,register_num)
+
+ pir_code .= retval
+ $S1 = "$P"
+ $S0 = register_num
+ $S1 .= $S0
+
+ inc register_num
+ $S0 = register_num
+ $S2 = "$S"
+ $S2 .= $S0
+
+ # Get a string version of the name
+ pir_code .= $S2
+ pir_code .= "="
+ pir_code .= $S1
+ pir_code .= "\n"
+
+ # Prepend a "&"
+ pir_code .= $S2
+ pir_code .= " = \"&\" . "
+ pir_code .= $S2
+ pir_code .= "\n"
+
+ pir_code .= "\ncommand = find_global \"Tcl\", "
+ pir_code .= $S2
+ pir_code .= "\n$P"
+
+ pir_code .= $S0
+ pir_code .= " = command("
+ ii = 0
+elem_loop:
+ if ii == num_args goto elem_loop_done
+ $S0 = compiled_args[ii]
+ pir_code .= "$P"
+ pir_code .= $S0
+ inc ii
+ if ii == num_args goto elem_loop_done
+ pir_code .= ","
+ goto elem_loop
+elem_loop_done:
+ pir_code .= ")\n"
+
+ # return the code and the new register_num
+ .return (register_num,pir_code)
+.end
Modified: trunk/languages/tcl/lib/tclconst.pir
==============================================================================
--- trunk/languages/tcl/lib/tclconst.pir (original)
+++ trunk/languages/tcl/lib/tclconst.pir Wed Sep 28 16:52:37 2005
@@ -266,3 +266,24 @@ Get the value of the const.
.sub interpret method
.return(self)
.end
+
+=head2 compile
+
+Generate PIR code which can be used to generate our value
+
+=cut
+
+.sub compile method
+ .param int argnum
+
+ .local string code
+
+ .local pmc value
+ $I0 = classoffset self, "TclConst"
+ value = getattribute self, $I0
+
+ .local pmc compiler
+ compiler = find_global "_Tcl", "compile"
+
+ .return compiler(value,argnum)
+.end
Modified: trunk/languages/tcl/lib/tclfunc.pir
==============================================================================
--- trunk/languages/tcl/lib/tclfunc.pir (original)
+++ trunk/languages/tcl/lib/tclfunc.pir Wed Sep 28 16:52:37 2005
@@ -47,25 +47,31 @@ Initialize the attributes for an instanc
setattribute self, "TclFunc\x00argument", $P0
.end
-.sub interpret method
- .local pmc retval
- # assigning a $Nx will change this to a TclFloat
-
- retval = new TclInt
+.sub compile method
+ .param int register_num
- .local pmc funcs, expr_interpret, __number
+ .local pmc retval
+ .local string pir_code
+ .local pmc funcs, __number, compile
funcs = find_global "_Tcl", "functions"
- expr_interpret = find_global "_Tcl", "__expression_interpret"
__number = find_global "_Tcl", "__number"
-
- .local pmc arg, name
- arg = getattribute self, "TclFunc\x00argument"
- retval = expr_interpret(arg)
+ compile = find_global "_Tcl", "compile"
+
+ # eventually, we'll need to deal with more than one arg.
+
+ .local pmc arg_code, arg_reg, name
+ $P1 = getattribute self, "TclFunc\x00argument"
+ (arg_reg,pir_code) = compile($P1,register_num)
+ inc register_num
+
+ # XXX We shouldn't store the name. we should store the opcode, avoid
+ # the lookup cost. (at least for builtins)
- arg = __number(retval)
name = getattribute self, "TclFunc\x00name"
-
$I0 = funcs[name]
+
+ .local string opcode_name
+
if $I0 == FUNCTION_ABS goto func_abs
if $I0 == FUNCTION_ACOS goto func_acos
if $I0 == FUNCTION_ASIN goto func_asin
@@ -82,75 +88,98 @@ Initialize the attributes for an instanc
if $I0 == FUNCTION_TANH goto func_tanh
func_abs:
- retval = abs arg
- goto done
+ .local pmc printf_args
+ printf_args = new .Array
+ printf_args = 2
+ printf_args[0] = register_num
+ printf_args[1] = arg_reg
+
+ pir_code .= "$P%i = abs $P%i\n"
+ goto done_all
+
func_acos:
- $N0 = arg
- $N1 = acos $N0
- retval = $N1
+ opcode_name = "acos"
goto done
+
func_asin:
- $N0 = arg
- $N1 = asin $N0
- retval = $N1
+ opcode_name = "asin"
goto done
+
func_atan:
- $N0 = arg
- $N1 = atan $N0
- retval = $N1
+ opcode_name = "atan"
goto done
+
func_cos:
- $N0 = arg
- $N1 = cos $N0
- retval = $N1
+ opcode_name = "cos"
goto done
+
func_cosh:
- $N0 = arg
- $N1 = cosh $N0
- retval = $N1
+ opcode_name = "cosh"
goto done
+
func_exp:
- $N0 = arg
- $N1 = exp $N0
- retval = $N1
+ opcode_name = "exp"
goto done
+
func_log:
- $N0 = arg
- $N1 = ln $N0
- retval = $N1
+ opcode_name = "ln"
goto done
+
func_log10:
- $N0 = arg
- $N1 = log10 $N0
- retval = $N1
+ opcode_name = "log10"
goto done
+
func_sin:
- $N0 = arg
- $N1 = sin $N0
- retval = $N1
+ opcode_name = "sin"
goto done
+
func_sinh:
- $N0 = arg
- $N1 = sinh $N0
- retval = $N1
+ opcode_name = "sinh"
goto done
+
func_sqrt:
- $N0 = arg
- $N1 = sqrt $N0
- retval = $N1
+ opcode_name = "sqrt"
goto done
+
func_tan:
- $N0 = arg
- $N1 = tan $N0
- retval = $N1
+ opcode_name = "tan"
goto done
+
func_tanh:
- $N0 = arg
- $N1 = tanh $N0
- retval = $N1
- #goto done
+ opcode_name = "tanh"
+
done:
- .return(retval)
+ .local pmc printf_args
+ printf_args = new .Array
+ printf_args = 8
+ printf_args[0] = register_num
+ printf_args[1] = arg_reg
+ printf_args[2] = register_num
+ printf_args[3] = opcode_name
+ printf_args[4] = register_num
+ printf_args[5] = register_num
+ printf_args[6] = register_num
+ printf_args[7] = register_num
+
+ pir_code .= "$N%i=$P%i\n"
+ pir_code .= "$N%i=%s $N%i\n"
+ pir_code .= "$P%i = new .TclFloat\n"
+ pir_code .= "$P%i=$N%i\n"
+
+
+done_all:
+
+ pir_code = sprintf pir_code, printf_args
+ .return(register_num,pir_code)
.end
+
+.sub __clone method
+ .local pmc obj
+ $I0 = typeof self
+ obj = new $I0
+ obj = self
+ .return(obj)
+.end
+
Modified: trunk/languages/tcl/lib/tclops.pir
==============================================================================
--- trunk/languages/tcl/lib/tclops.pir (original)
+++ trunk/languages/tcl/lib/tclops.pir Wed Sep 28 16:52:37 2005
@@ -62,3 +62,56 @@ done:
.return(retval)
.end
+
+.sub compile method
+ .param int register_num
+
+ .local string pir_code
+
+ .local pmc retval
+ retval = new TclInt
+
+ .local pmc name, operand, compile
+ name = getattribute self, "TclUnaryOp\x00name"
+ operand = getattribute self, "TclUnaryOp\x00operand"
+ compile = find_global "_Tcl", "compile"
+
+ .local string opcode
+
+ if name == "-" goto minus
+ if name == "+" goto plus
+ if name == "~" goto bitwise_not
+ if name == "!" goto logical_not
+
+minus:
+ opcode = "neg"
+ goto done
+
+plus:
+ .return compile(operand,register_num)
+
+bitwise_not:
+ opcode = "bnot"
+ goto done
+
+logical_not:
+ opcode = "not"
+done:
+ (register_num,pir_code) = compile(operand,register_num)
+
+ .local pmc printf_args
+ printf_args = new .Array
+ printf_args = 3
+ inc register_num
+ printf_args[0] = register_num
+ printf_args[1] = opcode
+ dec register_num
+ printf_args[2] = register_num
+ inc register_num
+
+ $S0 = sprintf "$P%i=%s $P%i\n", printf_args
+ pir_code .= $S0
+
+ .return(register_num, pir_code)
+
+.end
Modified: trunk/languages/tcl/lib/tclvar.pir
==============================================================================
--- trunk/languages/tcl/lib/tclvar.pir (original)
+++ trunk/languages/tcl/lib/tclvar.pir Wed Sep 28 16:52:37 2005
@@ -27,3 +27,22 @@ Get the value of the variable.
$S0 = self
.return read($S0)
.end
+
+.sub compile method
+ .param int register_num
+
+ .local string pir_code
+ .local pmc args
+
+ args = new .Array
+ args = 4
+ args[0] = register_num
+ $S0 = self
+ args[1] = $S0
+ args[2] = register_num
+ args[3] = register_num
+
+ pir_code = sprintf ".local pmc read\nread=find_global \"_Tcl\",
\"__read\"\n.local pmc number\nnumber=find_global \"_Tcl\", \"__number\"\n$P%i
= read(\"%s\")\n$P%i = number($P%i)\n", args
+
+ .return (register_num,pir_code)
+.end
Modified: trunk/languages/tcl/t/cmd_expr.t
==============================================================================
--- trunk/languages/tcl/t/cmd_expr.t (original)
+++ trunk/languages/tcl/t/cmd_expr.t Wed Sep 28 16:52:37 2005
@@ -2,9 +2,15 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 49;
+use Parrot::Test tests => 52;
use Test::More;
+language_output_is("tcl",<<TCL,<<OUT,"int");
+ puts [expr 42]
+TCL
+42
+OUT
+
language_output_is("tcl",<<TCL,<<OUT,"mul");
puts [expr 2 * 3]
TCL
@@ -48,6 +54,19 @@ TCL
4
OUT
+language_output_is("tcl",<<TCL,<<OUT,"lt, numeric, not alpha...");
+ puts [expr 10 < 9]
+TCL
+0
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"lt, numeric, not alpha, with vars");
+ set a 10
+ puts [expr $a < 9]
+TCL
+0
+OUT
+
language_output_is("tcl",<<TCL,<<OUT,"lt, true");
puts [expr 2 < 3]
TCL
@@ -160,7 +179,7 @@ F
0
OUT
-language_output_is("tcl",<<TCL,<<OUT,"&&, both sides");
+language_output_is("tcl",<<TCL,<<OUT,"||, both sides");
proc true {} {puts T; return 1}
proc false {} {puts F; return 0}
puts [expr {[false] || [true]}]
Modified: trunk/languages/tcl/t/tcl_misc.t
==============================================================================
--- trunk/languages/tcl/t/tcl_misc.t (original)
+++ trunk/languages/tcl/t/tcl_misc.t Wed Sep 28 16:52:37 2005
@@ -147,7 +147,3 @@ language_output_is("tcl",<<'TCL',<<'OUT'
TCL
ok
OUT
-
-
-
-
Modified: trunk/languages/tcl/tcl.pir_template
==============================================================================
--- trunk/languages/tcl/tcl.pir_template (original)
+++ trunk/languages/tcl/tcl.pir_template Wed Sep 28 16:52:37 2005
@@ -23,7 +23,6 @@ providing a compreg-compatible method.
# Still not sure if these are going to be useful
.const int BLOCK = 14
- .const int CHUNK = 15
.const int COMMAND = 16
@@ -49,6 +48,7 @@ providing a compreg-compatible method.
.const int OPERATOR_SHL = 43
.const int OPERATOR_SHR = 44
.const int OPERATOR_UNEQUAL= 45
+
.const int FUNCTION_ATAN2 = 46
.const int FUNCTION_FMOD = 47
.const int FUNCTION_POW = 48
@@ -120,7 +120,7 @@ providing a compreg-compatible method.
operators = new TclArray
precedence = new TclArray
- # This precedence check should be shoved into [expr]. There's no need
+ # XXX This precedence check should be shoved into [expr]. There's no need
# to make it this generic.
operators["*"] = OPERATOR_MUL
Modified: trunk/languages/tcl/tcl.pl
==============================================================================
--- trunk/languages/tcl/tcl.pl (original)
+++ trunk/languages/tcl/tcl.pl Wed Sep 28 16:52:37 2005
@@ -50,6 +50,8 @@ Generate the PIR code that matches the v
my $rulefile = "lib/tcl.p6r";
my $rules;
+=for later
+
open (RULES,$rulefile) or die "can't read rules file.\n";
$rules = <<'EOH';
@@ -81,6 +83,10 @@ EORULE
$rules .= ".end\n";
+=cut
+
+$rules = q{};
+
$contents =~ s/\${INCLUDES}/$includes/g;
$contents =~ s/\${HEADER}/This file automatically generated, do not edit./g;
$contents =~ s/\${RULES}/$rules/g;
