Author: leo
Date: Sun Aug 14 05:24:15 2005
New Revision: 8953
Removed:
branches/leo-ctx5/languages/tcl/lib/get_var.pir
Modified:
branches/leo-ctx5/MANIFEST
branches/leo-ctx5/config/gen/makefiles/tcl.in
branches/leo-ctx5/languages/tcl/TODO
branches/leo-ctx5/languages/tcl/classes/tclint.pmc
branches/leo-ctx5/languages/tcl/lib/commands/array.pir
branches/leo-ctx5/languages/tcl/lib/commands/info.pir
branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir
branches/leo-ctx5/languages/tcl/lib/commands/puts.pir
branches/leo-ctx5/languages/tcl/lib/commands/string.pir
branches/leo-ctx5/languages/tcl/lib/commands/unset.pir
branches/leo-ctx5/languages/tcl/lib/expression.pir
branches/leo-ctx5/languages/tcl/lib/list.pir
branches/leo-ctx5/languages/tcl/lib/parser.pir
branches/leo-ctx5/languages/tcl/lib/string.pir
branches/leo-ctx5/languages/tcl/lib/tclcommand.pir
branches/leo-ctx5/languages/tcl/lib/variables.pir
branches/leo-ctx5/languages/tcl/t/cmd_expr.t
branches/leo-ctx5/languages/tcl/tcl.pir
branches/leo-ctx5/languages/tcl/tcl.pir_template
Log:
merge -r8940:8952 from trunk
Modified: branches/leo-ctx5/MANIFEST
==============================================================================
--- branches/leo-ctx5/MANIFEST (original)
+++ branches/leo-ctx5/MANIFEST Sun Aug 14 05:24:15 2005
@@ -1420,7 +1420,6 @@ languages/tcl/lib/commands/upvar.pir
languages/tcl/lib/commands/while.pir [tcl]
languages/tcl/lib/conversions.pir [tcl]
languages/tcl/lib/expression.pir [tcl]
-languages/tcl/lib/get_var.pir [tcl]
languages/tcl/lib/interpret.pir [tcl]
languages/tcl/lib/list.pir [tcl]
languages/tcl/lib/list_to_string.pir [tcl]
Modified: branches/leo-ctx5/config/gen/makefiles/tcl.in
==============================================================================
--- branches/leo-ctx5/config/gen/makefiles/tcl.in (original)
+++ branches/leo-ctx5/config/gen/makefiles/tcl.in Sun Aug 14 05:24:15 2005
@@ -61,7 +61,6 @@ lib${slash}commands${slash}upvar.pir \
lib${slash}commands${slash}while.pir \
lib${slash}conversions.pir \
lib${slash}expression.pir \
-lib${slash}get_var.pir \
lib${slash}interpret.pir \
lib${slash}list.pir \
lib${slash}list_to_string.pir \
Modified: branches/leo-ctx5/languages/tcl/TODO
==============================================================================
--- branches/leo-ctx5/languages/tcl/TODO (original)
+++ branches/leo-ctx5/languages/tcl/TODO Sun Aug 14 05:24:15 2005
@@ -61,18 +61,6 @@ TclList's new_from_string method should
=over 4
-=item __set/__read
-
-All commands should use the __set and __read functions defined in
-variables.pir instead of get_var. __read's interface conflicts slightly
-with the way tclparser splits things up - it over-helpfully tries to
-break the variable part out into array and index - while read is
-already doing that for us.
-
-On a related note: No builtins or library code should be dealing with var
-sigils (i.e. C<$>) other than __set and __read {{ possibly array, since
-it needs to fetch the entire array: gen a new sub for this }}
-
=item implement default globals, etc.
global variables provided by tcl libary. L<tclvars>.
Modified: branches/leo-ctx5/languages/tcl/classes/tclint.pmc
==============================================================================
--- branches/leo-ctx5/languages/tcl/classes/tclint.pmc (original)
+++ branches/leo-ctx5/languages/tcl/classes/tclint.pmc Sun Aug 14 05:24:15 2005
@@ -18,17 +18,30 @@ pmclass TclInt extends TclObject extends
* TclInt shouldn't automatically promote division to float.
*/
PMC* divide (PMC* value, PMC* dest) {
- INTVAL n = PMC_int_val(SELF);
- INTVAL d = PMC_int_val(value);
+ MMD_TclInt: {
+ INTVAL n = PMC_int_val(SELF);
+ INTVAL d = PMC_int_val(value);
- if (d == 0)
- real_exception(INTERP, NULL, E_ZeroDivisionError, "divide by zero");
+ if (d == 0)
+ real_exception(INTERP, NULL, E_ZeroDivisionError, "divide by
zero");
- if (!dest)
- dest = pmc_new(INTERP, SELF->vtable->base_type);
+ if (!dest)
+ dest = pmc_new(INTERP, SELF->vtable->base_type);
- PMC_int_val(dest) = n / d;
- return dest;
+ PMC_int_val(dest) = n / d;
+ return dest;
+ }
+ MMD_DEFAULT: {
+ FLOATVAL d = VTABLE_get_number(INTERP, value);
+
+ if (d == 0.0)
+ real_exception(INTERP, NULL, E_ZeroDivisionError, "float division
by zero");
+
+ if (!dest)
+ dest = pmc_new(INTERP, SELF->vtable->base_type);
+ VTABLE_set_number_native(INTERP, dest, DYNSELF.get_number() / d);
+ return dest;
+ }
}
}
Modified: branches/leo-ctx5/languages/tcl/lib/commands/array.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/array.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/array.pir Sun Aug 14
05:24:15 2005
@@ -26,7 +26,7 @@
subcommand_proc = find_global "_Tcl\0builtins\0array", subcommand_name
resume:
clear_eh
- isnull subcommand_proc, bad_args
+ if_null subcommand_proc, bad_args
.local int is_array
.local string array_name, sigil_array_name
@@ -51,7 +51,7 @@ resume_var:
catch_var:
- isnull the_array, array_no
+ if_null the_array, array_no
$I99 = does the_array, "hash"
if $I99==0 goto array_no
@@ -169,7 +169,7 @@ pre_loop:
.local pmc set
set = find_global "_Tcl", "__set"
- isnull the_array, new_array
+ if_null the_array, new_array
goto set_loop
new_array:
Modified: branches/leo-ctx5/languages/tcl/lib/commands/info.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/info.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/info.pir Sun Aug 14
05:24:15 2005
@@ -24,7 +24,7 @@
subcommand_proc = find_global "_Tcl\0builtins\0info", subcommand_name
resume:
clear_eh
- isnull subcommand_proc, bad_args
+ if_null subcommand_proc, bad_args
.return subcommand_proc(argv)
catch:
@@ -55,7 +55,7 @@ bad_args:
procname = shift argv
$P1 = find_global "_Tcl", "proc_args"
$P2 = $P1[procname]
- isnull $P2, no_args
+ if_null $P2, no_args
.return(TCL_OK,$P2)
no_args:
@@ -85,7 +85,7 @@ bad_args:
procname = shift argv
$P1 = find_global "_Tcl", "proc_body"
$P2 = $P1[procname]
- isnull $P2, no_body
+ if_null $P2, no_body
.return(TCL_OK,$P2)
no_body:
@@ -144,7 +144,7 @@ bad_args:
$P1 = find_global "Tcl", varname
global_resume:
clear_eh
- isnull $P1, lex
+ if_null $P1, lex
retval = 1
.return(TCL_OK,retval)
@@ -158,7 +158,7 @@ lex:
$P1 = find_lex $I1, varname
lex_resume:
clear_eh
- isnull $P1, nope
+ if_null $P1, nope
retval = 1
.return(TCL_OK,retval)
Modified: branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/namespace.pir Sun Aug 14
05:24:15 2005
@@ -27,7 +27,7 @@ real top level namespace.
subcommand_proc = find_global "_Tcl\0builtins\0namespace", subcommand_name
resume:
clear_eh
- isnull subcommand_proc, bad_args
+ if_null subcommand_proc, bad_args
.return subcommand_proc(argv)
catch:
Modified: branches/leo-ctx5/languages/tcl/lib/commands/puts.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/puts.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/puts.pir Sun Aug 14
05:24:15 2005
@@ -29,7 +29,7 @@ three_arg:
channels = find_global "_Tcl", "channels"
$S2 = argv[1]
$P1 = channels[$S2]
- isnull $P1, bad_channel
+ if_null $P1, bad_channel
$S3 = argv[2]
print $P1, $S3
goto done
@@ -49,7 +49,7 @@ two_arg_channel:
.local pmc channels
channels = find_global "_Tcl", "channels"
$P1 = channels[$S2]
- isnull $P1, bad_channel
+ if_null $P1, bad_channel
print $P1, $S3
print $P1, "\n"
goto done
Modified: branches/leo-ctx5/languages/tcl/lib/commands/string.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/string.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/string.pir Sun Aug 14
05:24:15 2005
@@ -19,7 +19,7 @@
subcommand_proc = find_global "_Tcl\0builtins\0string", subcommand_name
resume:
clear_eh
- isnull subcommand_proc, bad_args
+ if_null subcommand_proc, bad_args
.return subcommand_proc(argv)
catch:
Modified: branches/leo-ctx5/languages/tcl/lib/commands/unset.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/unset.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/unset.pir Sun Aug 14
05:24:15 2005
@@ -25,7 +25,6 @@
call_level = $P0
.local pmc search_variable
- # XXX Should use get_var?
push_eh catch
if call_level goto get_lexical
search_variable = find_global "Tcl", varname
@@ -35,7 +34,7 @@ get_lexical:
resume:
clear_eh
- isnull search_variable, error
+ if_null search_variable, error
null search_variable
Modified: branches/leo-ctx5/languages/tcl/lib/expression.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/expression.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/expression.pir Sun Aug 14 05:24:15 2005
@@ -101,7 +101,7 @@ get_paren_done:
if return_type == TCL_ERROR goto die_horribly
chunk = new TclList
- chunk[0] = INTEGER
+ chunk[0] = OPERAND
chunk[1] = retval
push chunks, chunk
@@ -109,44 +109,16 @@ get_paren_done:
goto chunk_loop
get_variable:
- .local pmc varname
-
- # XXX expr_get_variable should just call __get_var for us,
- # so we don't have to jump through these hoops.
-
- (op_length,retval) = __expr_get_variable(expr,chunk_start)
- if op_length == 0 goto get_function
-
- $I0 = retval
- if $I0 == 2 goto got_array
- $S0 = retval[0]
- ($I0,retval) = __get_var($S0)
- goto get_variable_continue
-got_array:
- $S0 = retval[0]
- $S1 = retval[1]
- ($I0,retval) = __get_var($S0,$S1)
-
-get_variable_continue:
- # XXX This is a hack until we deal with types better in
- $N1 = retval
- retval = new TclFloat
- retval = $N1
- #print "__get_var returned something of type:"
- $S0 = typeof retval
- #print $S0
- #print "\n"
- # XXX ignoring $I0 at the minute.
- #(return_type,retval) = __expression($P0)
- #error_S = retval
- #if return_type == TCL_ERROR goto die_horribly
- # Temporarily pump this out to the array.
+ (retval, chunk_start) = parse_variable(expr, chunk_start)
+ $P0 = retval."interpret"()
+ $I0 = $P0
+ retval = new TclInt
+ retval = $I0
+
chunk = new TclList
- chunk[0] = INTEGER
+ chunk[0] = OPERAND
chunk[1] = retval
push chunks, chunk
-
- chunk_start = chunk_start + op_length
dec chunk_start
goto chunk_loop
@@ -158,7 +130,7 @@ get_function:
.local pmc result
(op_length,func,result) = __expr_get_function(expr,chunk_start)
- if op_length == 0 goto get_number
+ if op_length == 0 goto get_operator
chunk = new TclList
chunk[0] = FUNC
chunk[1] = func
@@ -172,15 +144,14 @@ get_function:
get_number:
#print "GET_NUMBER\n"
# If we got here, then char and chunk_start are already set properly
- .local int num_type
.local pmc value
- (op_length,num_type,value) = __expr_get_number(expr,chunk_start)
+ (op_length,value) = __expr_get_number(expr,chunk_start)
#print "GOT_NUMBER\n"
if op_length == 0 goto get_operator
# XXX otherwise, pull that number off
# stuff the chunk onto the chunk_list
chunk = new TclList
- chunk[0] = INTEGER
+ chunk[0] = OPERAND
chunk[1] = value
push chunks, chunk
chunk_start += op_length
@@ -206,7 +177,7 @@ two_char:
op_len = 2
test_op = substr expr, chunk_start, op_len
$P11 = ops[test_op]
- isnull $P11, one_char
+ if_null $P11, one_char
$I1 = typeof $P11
if $I1 == .Undef goto one_char
goto op_done
@@ -216,7 +187,7 @@ one_char:
op_len = 1
test_op = substr expr, chunk_start, op_len
$P11 = ops[test_op]
- isnull $P11, op_fail
+ if_null $P11, op_fail
$I1 = typeof $P11
if $I1 == .Undef goto op_fail
goto op_done
@@ -286,11 +257,11 @@ converter_loop:
if precedence_level > MAX_PRECEDENCE goto converter_done
if stack_index >= input_len goto precedence_done
our_op = chunks[stack_index]
- isnull our_op, converter_next
+ if_null our_op, converter_next
$I0 = typeof our_op
if $I0 == .Undef goto converter_next
$I2 = our_op[0]
- if $I2 == INTEGER goto converter_next
+ if $I2 == OPERAND goto converter_next
if $I2 == CHUNK goto converter_next
if $I2 == OP goto is_opfunc
if $I2 == FUNC goto is_opfunc # XXX should eventually go away as we make
functions part of "CHUNK", above.
@@ -308,7 +279,7 @@ right_arg:
$I2 = stack_index + 1
if $I2 >= input_len goto left_arg
retval = chunks[$I2]
- isnull retval, left_arg
+ if_null retval, left_arg
chunks[$I2] = undef
inc $I4
program_stack = unshift retval
@@ -323,7 +294,7 @@ left_arg:
$I2 = stack_index - 1
if $I2 < 0 goto shift_op
retval = chunks[$I2]
- isnull retval, shift_op
+ if_null retval, shift_op
chunks[$I2] = undef
inc $I4
program_stack = unshift retval
@@ -370,29 +341,24 @@ converter_done:
# is this dup neeeded?
.local pmc program_stack
- # _dumper(args,"ARGS")
program_stack = args
.local pmc result_stack
result_stack = new TclList
.local pmc retval
.local int return_type
-# evaluate the stack.
+
stack_evaluator:
- #print "STACK_EVALUATOR\n"
# while the prog stack exists:
.local int size
size = program_stack
if size == 0 goto stack_done
- #print "stack_eval2?\n"
.local int type
.local pmc chunk
- pop chunk, program_stack
- #print "stack_eval3?\n"
+ chunk = pop program_stack
$I10 = typeof chunk
if $I10 == .Undef goto stack_evaluator
- type = chunk[0]
- #print "stack_eval4?\n"
+ type = chunk[0]
# move all non op non funcs to the value stack
if type == OP goto do_op
@@ -459,6 +425,8 @@ do_op:
if func == OPERATOR_BITAND goto op_bitand
if func == OPERATOR_BITXOR goto op_bitxor
if func == OPERATOR_BITOR goto op_bitor
+ if func == OPERATOR_NE goto op_ne
+ if func == OPERATOR_EQ goto op_eq
func_list:
if func == FUNCTION_ABS goto func_abs
if func == FUNCTION_ACOS goto func_acos
@@ -538,6 +506,20 @@ op_bitxor:
op_bitor:
op_result = bor l_arg, r_arg
goto done_op
+op_ne:
+ op_result = 1
+ $S0 = l_arg
+ $S1 = r_arg
+ if $S0 != $S1 goto done_op
+ op_result = 0
+ goto done_op
+op_eq:
+ op_result = 1
+ $S0 = l_arg
+ $S1 = r_arg
+ if $S0 == $S1 goto done_op
+ op_result = 0
+ goto done_op
func_abs:
# XXX This isn't int only, izzit?
$I0 = l_arg
@@ -620,7 +602,7 @@ done_op:
#print "\n"
$P5 = new FixedPMCArray
$P5 = 2
- $P5[0] = INTEGER
+ $P5[0] = OPERAND
$P5[1] = op_result
push result_stack, $P5
@@ -632,30 +614,23 @@ done_op:
#goto evaluation_done
stack_done:
- #print "STACK_DONE\n"
$I0 = result_stack
- #error_S = "no stack left."
if $I0 == 0 goto die_horribly
- pop retval, result_stack
+ retval = pop result_stack
goto evaluation_done
die_horribly:
- #print "dying horribly\n"
return_type = TCL_ERROR
retval = new String
retval = "An error occurred in EXPR"
goto evaluation_return
evaluation_done:
- #print "EVALUATION_DONE:\n"
return_type = TCL_OK
- #retval = retval[1] # skip the extra PMC here.
- $P1 = retval[1]
+ retval = retval[1]
evaluation_return:
- .return(return_type,$P1)
- #.return(return_type,retval)
-
+ .return(return_type,retval)
.end
# given a string, starting at position, return the length
@@ -664,194 +639,55 @@ evaluation_return:
.sub __expr_get_number
.param string expr
- .param int start
+ .param int pos
.local int len
len = length expr
- .local int pos
- .local int char
- .local int flag
+ .local int char, start
.local pmc value
- value = new Integer
+ null value
- pos = start
+ start = pos
if pos >= len goto failure
-
- goto decimal
-first_digit:
- # Is the first digit a 0? if so, this is octal or hex.
- $I0 = ord expr, pos
- if $I0 != 48 goto decimal
- #inc pos
- #ord $I0, expr, pos
- #if $I0 == 120 goto hexadecimal
-
- # XXX The octal code path doesn't work.
-
-octal:
- inc pos
-octal_loop:
- if pos>=len goto octal_loop_done
- $I0 = ord expr,pos
- if $I0 > 55 goto octal_loop_done # ">8"
- if $I0 < 48 goto octal_loop_done # "<0
- flag = 1
+integer:
+ if pos >= len goto integer_done
+ char = ord expr, pos
+ if char > 57 goto integer_done # > "9"
+ if char < 48 goto integer_done # < "0"
inc pos
- goto octal_loop
-octal_loop_done:
- pos = pos - start
- if flag == 1 goto octal_finish_up
- goto failure
-octal_finish_up:
- # get the string containing the octal digits.
- inc start
- dec pos
-
+ goto integer
+integer_done:
+ if char == 46 goto floating
+ pos -= start
+ if pos == 0 goto done # failure
+
$S0 = substr expr, start, pos
- $P1 = new TclList
- $P1[0] = $S0
-
- sprintf $S0, "%o", $P1
$I0 = $S0
+ value = new TclInt
value = $I0
- goto real_done
+ goto done
-decimal:
- flag = 0
-loop:
- # cheat
- if pos >= len goto loop_done
- $I0 = ord expr, pos
- if $I0 > 57 goto loop_done # > "9"
- if $I0 < 48 goto loop_done # < "0"
- flag = 1
+floating:
inc pos
- goto loop
-loop_done:
- pos = pos - start
- if flag == 1 goto finish_up
-
-failure:
- pos = 0
- goto real_done
-
-finish_up:
- $S0 = substr expr, start, pos
- $I0 = $S0
- value = new TclInt
- value = $I0
-
-real_done:
- .return(pos,INTEGER,value)
-.end
-
-# given a string, starting at position, return the length
-# of the variable name found at that position. return 0
-# if this doesn't look like a variable. If the return value
-# is non zero, also return a array-ish PMC that either has a
-# single element ($name or ${name}), or two elements
-# $name{index}
-
-.sub __expr_get_variable
- .param string expr
- .param int start
-
- .local int pos
- pos = 0
-
- .local pmc varname
- varname = new FixedPMCArray
-
- .local int expr_length
- expr_length = length expr
-
- # is this even a variable?
- $I0 = ord expr, start
- if $I0 != 36 goto real_done
-
- inc start
- $I0 = ord expr, start
- if $I0 == 123 goto braced
-
- pos = start
-var_loop:
- # a regular variable, "letter, digit, underscore, two or more colons"
- # (XXX not really handling multiple colons right now)
-
- # paren - 40
- # digit 48-57
- # colon 58
- # LETTER 65-90
- # underscore 95
- # letter 97-122
-
- if pos >= expr_length goto var_loop_done
-
- $I0 = ord expr, pos
- if $I0 == 40 goto indexed_var
- if $I0 < 48 goto var_loop_done
- if $I0 <= 58 goto var_loop_next
- if $I0 < 65 goto var_loop_done
- if $I0 <= 90 goto var_loop_next
- if $I0 == 95 goto var_loop_next
- if $I0 < 97 goto var_loop_done
- if $I0 > 122 goto var_loop_done
- # (only thing left is a letter, so fall through)
-
-var_loop_next:
+float_loop:
+ if pos >= len goto float_done
+ char = ord expr, pos
+ if char > 57 goto float_done # > "9"
+ if char < 48 goto float_done # < "0"
inc pos
- goto var_loop
-
-var_loop_done:
-
- $I0 = pos - start
-
- $S0 = substr expr, start, $I0
- varname = 1
- varname[0] = $S0
- goto real_done
-
-indexed_var:
- # just like var_loop_done, mark the name of the var
- dec pos
- $I0 = pos - start
- $S0 = substr expr, start, $I0
- varname = 2
- varname[0] = $S0
-
- # now, move to the beginning of the index, find the closing paren
- pos = pos + 2
- index $I1, ")", expr, pos
-
- $I2 = $I1 - pos
- $S0 = substr expr, pos, $I2
- varname[1] = $S0
- goto real_done
-
-braced:
- inc start # now at the character right after the {
- # "may contain any characters whatsoever except for close braces"
- # (so, next close brace closes us.) - 125
- index $I0, expr, "}", start
- if $I0 == -1 goto real_done # XXX need to somehow error here.
- pos = $I0
-
- $I1 = $I0 - start
- $S0 = substr expr, start, $I1
- varname[0] = $S0
-
+ goto float_loop
+float_done:
+ pos -= start
-real_done:
-
-dd:
- #print "pos is"
- #print pos
- #print "\n&&varname is"
- #print $S0
- #print "\n"
+ $S0 = substr expr, start, pos
+ $N0 = $S0
+ value = new TclFloat
+ value = $N0
+ # goto done
- .return(pos,varname)
+done:
+ .return(pos,value)
.end
.sub __expr_get_function
@@ -905,7 +741,7 @@ loop_done:
$P1 = find_global "_Tcl", "functions"
func = $P1[$S0]
- isnull func, fail
+ if_null func, fail
$I0 = typeof func
if $I0 == .Undef goto fail
@@ -925,7 +761,7 @@ loop_done:
($I9,operand) = __expression_interpret(operand)
$P10 = new FixedPMCArray
$P10 = 2
- $P10[0] = INTEGER
+ $P10[0] = OPERAND
$P10[1] = operand
operand = $P10
if $I9 == TCL_ERROR goto fail
@@ -960,7 +796,7 @@ was this a valid tcl-style level, or did
current_call_level = find_global "_Tcl", "call_level"
orig_level = current_call_level
- .local int num_length, num_type
+ .local int num_length
get_absolute:
# Is this an absolute?
@@ -968,8 +804,9 @@ get_absolute:
$S1 = substr $S0, 0, 1
if $S1 != "#" goto get_integer
$S0 = tcl_level
- (num_length,num_type,parrot_level) = __expr_get_number($S0,1)
- if num_type != INTEGER goto default
+ (num_length,parrot_level) = __expr_get_number($S0,1)
+ $I0 = isa parrot_level, "Integer"
+ if $I0 == 0 goto default
$S0 = tcl_level
$I0 = length $S0
@@ -980,8 +817,9 @@ get_absolute:
get_integer:
# Is this an integer?
$S0 = tcl_level
- (num_length,num_type,parrot_level) = __expr_get_number($S0,0)
- if num_type != INTEGER goto default
+ (num_length,parrot_level) = __expr_get_number($S0,0)
+ $I0 = isa parrot_level, "Integer"
+ if $I0 == 0 goto default
$S0 = tcl_level
$I0 = length $S0
if $I0 != num_length goto default
Modified: branches/leo-ctx5/languages/tcl/lib/list.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/list.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/list.pir Sun Aug 14 05:24:15 2005
@@ -20,7 +20,7 @@
.local int return_type
return_type = TCL_OK
- .local int index_length,number_length,number_type
+ .local int index_length,number_length
.local pmc number_result
if position == "end" goto my_end
@@ -28,9 +28,10 @@
$S0 = substr position, 0, 4
if $S0 == "end-" goto has_end
index_length = length position
- (number_length,number_type,retval) = __expr_get_number(position,0)
- if number_type != INTEGER goto bad_arg
+ (number_length,retval) = __expr_get_number(position,0)
if number_length != index_length goto bad_arg
+ $I0 = isa retval, "Integer"
+ if $I0 == 0 goto bad_arg
# if the number is greater than the number of elements
# in the list, we want the end
@@ -55,9 +56,10 @@ has_end:
index_length = length position
index_length -= 4 # ignore "end-"
# is this an int?
- (number_length,number_type,number_result) = __expr_get_number(position,4)
- if number_type != INTEGER goto bad_arg
+ (number_length,number_result) = __expr_get_number(position,4)
if number_length != index_length goto bad_arg
+ $I0 = isa number_result, "Integer"
+ if $I0 == 0 goto bad_arg
# say, 1 if -1
$I0 = number_result
# say, 2 if -2
Modified: branches/leo-ctx5/languages/tcl/lib/parser.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/parser.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/parser.pir Sun Aug 14 05:24:15 2005
@@ -81,7 +81,7 @@ found_comment:
done_comment:
.local pmc command
(command, pos) = get_command(tcl_code, chars, pos)
- isnull command, done
+ if_null command, done
push commands, command
goto next_command
@@ -120,7 +120,7 @@ get:
if pos >= len goto check
(word, pos) = get_word(tcl_code, chars, pos)
inc pos
- isnull word, get
+ if_null word, get
$S0 = word
$I0 = ord $S0, 0
if $I0 == 35 goto got_comment
@@ -157,7 +157,7 @@ get:
# try to get a command name
.local pmc word
(word, pos) = get_word(tcl_code, chars, pos)
- isnull word, check
+ if_null word, check
$I0 = find_type "TclCommand"
command = new $I0
@@ -165,7 +165,7 @@ get:
next_word:
(word, pos) = get_word(tcl_code, chars, pos)
- isnull word, done
+ if_null word, done
push command, word
goto next_word
@@ -294,7 +294,7 @@ have_word:
goto done
done:
- isnull word, really_done
+ if_null word, really_done
$I0 = word
if $I0 != 1 goto really_done
word = word[0]
Modified: branches/leo-ctx5/languages/tcl/lib/string.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/string.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/string.pir Sun Aug 14 05:24:15 2005
@@ -20,7 +20,6 @@
.local pmc retval
.local int index_length
.local int number_length
- .local int number_type
.local pmc number_result
.local int index_1
@@ -31,9 +30,10 @@
if $S0 == "end-" goto has_end
index_length = length $S0
# is this an int?
- (number_length,number_type,retval) = __expr_get_number(position,0)
- if number_type != INTEGER goto bad_arg
+ (number_length,retval) = __expr_get_number(position,0)
if number_length != index_length goto bad_arg
+ $I0 = isa retval, "Integer"
+ if $I0 == 0 goto bad_arg
goto done
#if not, fail.
@@ -50,9 +50,10 @@ has_end:
index_length = length position
index_length -= 4 # ignore "end-"
# is this an int?
- (number_length,number_type,number_result) = __expr_get_number(position,4)
- if number_type != INTEGER goto bad_arg
+ (number_length,number_result) = __expr_get_number(position,4)
if number_length != index_length goto bad_arg
+ $I0 = isa number_result, "Integer"
+ if $I0 == 0 goto bad_arg
# say, 1 if -1
$I0 = number_result
# say, 2 if -2
Modified: branches/leo-ctx5/languages/tcl/lib/tclcommand.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/tclcommand.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/tclcommand.pir Sun Aug 14 05:24:15 2005
@@ -61,7 +61,7 @@ Execute the command.
# we can't delete commands, so we store deleted commands
# as null PMCs
- isnull cmd, no_command
+ if_null cmd, no_command
execute:
.local pmc args
Modified: branches/leo-ctx5/languages/tcl/lib/variables.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/variables.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/variables.pir Sun Aug 14 05:24:15 2005
@@ -41,7 +41,7 @@ array:
key = substr name, char, len
variable = __find_var(var)
- isnull variable, no_such_variable
+ if_null variable, no_such_variable
$I0 = does variable, "hash"
unless $I0 goto cant_read_not_array
@@ -52,7 +52,7 @@ array:
#unless $I0 goto bad_index
variable = variable[key]
- isnull variable,bad_index
+ if_null variable, bad_index
.return(TCL_OK, variable)
bad_index:
@@ -73,7 +73,7 @@ cant_read_not_array:
scalar:
variable = __find_var(name)
- isnull variable, no_such_variable
+ if_null variable, no_such_variable
$I0 = does variable, "hash"
if $I0 goto cant_read_array
@@ -139,7 +139,7 @@ find_array:
.local pmc array
null array
array = __find_var(var)
- isnull array, create_array
+ if_null array, create_array
$I0 = does array, "hash"
unless $I0 goto cant_set_not_array
Modified: branches/leo-ctx5/languages/tcl/t/cmd_expr.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/cmd_expr.t (original)
+++ branches/leo-ctx5/languages/tcl/t/cmd_expr.t Sun Aug 14 05:24:15 2005
@@ -254,8 +254,12 @@ TCL
syntax error in expression "(": premature end of expression
OUT
-TODO: {
-local $TODO = "bugs";
+language_output_is("tcl",<<'TCL',<<'OUT',"braced operands.");
+ set n 1
+ puts [expr {$n * 1}]
+TCL
+1
+OUT
language_output_is("tcl",<<'TCL',<<'OUT',"float division");
puts [expr 1 / 3.0]
@@ -263,12 +267,8 @@ TCL
0.333333333333
OUT
-language_output_is("tcl",<<'TCL',<<'OUT',"braced operands.");
- set n 1
- puts [expr {$n * 1}]
-TCL
-1
-OUT
+TODO: {
+local $TODO = "bugs";
language_output_is("tcl",<<'TCL',<<'OUT',"nested expr (braces)");
puts [expr {2 * [expr {2 - 1}]}];
Modified: branches/leo-ctx5/languages/tcl/tcl.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/tcl.pir (original)
+++ branches/leo-ctx5/languages/tcl/tcl.pir Sun Aug 14 05:24:15 2005
@@ -49,7 +49,7 @@ input_loop:
register $P1
(retcode,retval) = interpret($P1)
# print out the result of the evaluation.
- isnull retval, input_loop
+ if_null retval, input_loop
if retval == "" goto input_loop
print retval
print "\n"
Modified: branches/leo-ctx5/languages/tcl/tcl.pir_template
==============================================================================
--- branches/leo-ctx5/languages/tcl/tcl.pir_template (original)
+++ branches/leo-ctx5/languages/tcl/tcl.pir_template Sun Aug 14 05:24:15 2005
@@ -25,8 +25,7 @@ providing a compreg-compatible method.
.const int OP = 20
.const int FUNC = 21
- # XXX Should be changed to OPERAND
- .const int INTEGER = 11
+ .const int OPERAND = 11
# Still not sure if these are going to be useful
.const int BLOCK = 14
@@ -36,6 +35,8 @@ providing a compreg-compatible method.
# Constants for operator/function lookup.
+ .const int OPERATOR_EQ = 28
+ .const int OPERATOR_NE = 29
.const int OPERATOR_BITAND = 30
.const int OPERATOR_BITOR = 31
.const int OPERATOR_BITXOR = 32
@@ -148,7 +149,11 @@ providing a compreg-compatible method.
operators["=="] = OPERATOR_EQUAL
precedence["=="] = 5
operators["!="] = OPERATOR_UNEQUAL
- precedence["!="] = 5
+ precedence["!="] = 5
+ operators["ne"] = OPERATOR_NE
+ precedence["ne"] = 6
+ operators["eq"] = OPERATOR_EQ
+ precedence["eq"] = 6
operators["&"] = OPERATOR_BITAND
precedence["&"] = 7
operators["^"] = OPERATOR_BITXOR
