Author: mdiep
Date: Sat Aug 20 11:14:56 2005
New Revision: 9009
Added:
trunk/languages/tcl/lib/tclfunc.pir
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/tcl.in
trunk/languages/tcl/lib/expression.pir
trunk/languages/tcl/tcl.pir_template
trunk/languages/tcl/tcl.pl
Log:
- Add a TclFunc class (move all the expr function logic there)
- Get rid of the FUNC constant
- Use TclFunc objects to make functions operands
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sat Aug 20 11:14:56 2005
@@ -1427,6 +1427,7 @@ languages/tcl/lib/string_to_list.pir
languages/tcl/lib/string.pir [tcl]
languages/tcl/lib/tclcommand.pir [tcl]
languages/tcl/lib/tclconst.pir [tcl]
+languages/tcl/lib/tclfunc.pir [tcl]
languages/tcl/lib/tclvar.pir [tcl]
languages/tcl/lib/tclword.pir [tcl]
languages/tcl/lib/tcl.p6r [tcl]
Modified: trunk/config/gen/makefiles/tcl.in
==============================================================================
--- trunk/config/gen/makefiles/tcl.in (original)
+++ trunk/config/gen/makefiles/tcl.in Sat Aug 20 11:14:56 2005
@@ -74,7 +74,7 @@ lib${slash}variables.pir \
tcl.pir_template \
tcl.pl
-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
+tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclcommand.pbc
lib${slash}tclconst.pbc lib${slash}tclfunc.pbc lib${slash}tclvar.pbc
lib${slash}tclword.pbc tcl.pir
$(PARROT) --output=tcl.pbc tcl.pir
pmcs:
@@ -98,6 +98,9 @@ lib${slash}tclcommand.pbc: lib${slash}tc
lib${slash}tclconst.pbc: lib${slash}tclconst.pir
$(PARROT) --output=$(LIBPATH)${slash}tclconst.pbc
$(LIBPATH)${slash}tclconst.pir
+lib${slash}tclfunc.pbc: lib${slash}tclfunc.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclfunc.pbc
$(LIBPATH)${slash}tclfunc.pir
+
lib${slash}tclvar.pbc: lib${slash}tclvar.pir
$(PARROT) --output=$(LIBPATH)${slash}tclvar.pbc
$(LIBPATH)${slash}tclvar.pir
Modified: trunk/languages/tcl/lib/expression.pir
==============================================================================
--- trunk/languages/tcl/lib/expression.pir (original)
+++ trunk/languages/tcl/lib/expression.pir Sat Aug 20 11:14:56 2005
@@ -133,16 +133,13 @@ get_function:
# Does the string of characters here match one of our pre-defined
# functions? If so, put that function on the stack.
.local pmc func
- .local pmc result
- (op_length,func,result) = __expr_get_function(expr,chunk_start)
+ (op_length,func) = __expr_get_function(expr,chunk_start)
if op_length == 0 goto get_operator
chunk = new TclList
- chunk[0] = FUNC
+ chunk[0] = OPERAND
chunk[1] = func
- chunk[2] = -1 # functions trump operands, for now.
push chunks, chunk
- push chunks, result
chunk_start += op_length
dec chunk_start
goto chunk_loop
@@ -266,7 +263,6 @@ converter_loop:
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.
# Should never be reached (XXX then shouldn't we die horribly?)
goto converter_next
@@ -356,7 +352,6 @@ stack_evaluator:
# move all non op non funcs to the value stack
if type == OP goto do_op
- if type == FUNC goto do_op
$P0 = chunk[1]
$P0 = $P0."interpret"()
chunk[1] = $P0
@@ -367,8 +362,8 @@ 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 func
- func = chunk[1]
+ .local int op
+ op = chunk[1]
# XXX assume all operands take two args.
.local pmc r_arg
@@ -378,44 +373,28 @@ do_op:
l_arg = pop result_stack
l_arg = l_arg[1]
- if func >= FUNCTION_ABS goto func_list
r_arg = pop result_stack
r_arg = r_arg[1]
# Is there a more efficient way to do this dispatch?
- if func == OPERATOR_MUL goto op_mul
- if func == OPERATOR_DIV goto op_div
- if func == OPERATOR_MOD goto op_mod
- if func == OPERATOR_PLUS goto op_plus
- if func == OPERATOR_MINUS goto op_minus
- if func == OPERATOR_SHL goto op_shl
- if func == OPERATOR_SHR goto op_shr
- if func == OPERATOR_LT goto op_lt
- if func == OPERATOR_GT goto op_gt
- if func == OPERATOR_LTE goto op_lte
- if func == OPERATOR_GTE goto op_gte
- if func == OPERATOR_EQUAL goto op_equal
- if func == OPERATOR_UNEQUAL goto op_unequal
- 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
- if func == FUNCTION_ASIN goto func_asin
- if func == FUNCTION_ATAN goto func_atan
- if func == FUNCTION_COS goto func_cos
- if func == FUNCTION_COSH goto func_cosh
- if func == FUNCTION_EXP goto func_exp
- if func == FUNCTION_LOG goto func_log
- if func == FUNCTION_LOG10 goto func_log10
- if func == FUNCTION_SIN goto func_sin
- if func == FUNCTION_SINH goto func_sinh
- if func == FUNCTION_SQRT goto func_sqrt
- if func == FUNCTION_TAN goto func_tan
- if func == FUNCTION_TANH goto func_tanh
+ 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
#error_S = "invalid function lookup returned"
goto die_horribly
@@ -493,78 +472,7 @@ op_eq:
$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
- $I1 = abs $I0
- op_result = $I1
- goto done_op
-func_acos:
- $N0 = l_arg
- $N1 = acos $N0
- op_result = $N1
- goto done_op
-func_asin:
- $N0 = l_arg
- $N1 = asin $N0
- op_result = $N1
- goto done_op
-func_atan:
- $N0 = l_arg
- $N1 = atan $N0
- op_result = $N1
- goto done_op
-func_cos:
- $N0 = l_arg
- $N1 = cos $N0
- op_result = $N1
- goto done_op
-func_cosh:
- $N0 = l_arg
- $N1 = cosh $N0
- op_result = $N1
- goto done_op
-func_exp:
- $N0 = l_arg
- $N1 = exp $N0
- op_result = $N1
- goto done_op
-func_log:
- $N0 = l_arg
- $N1 = ln $N0
- op_result = $N1
- goto done_op
-func_log10:
- $N0 = l_arg
- $N1 = log10 $N0
- op_result = $N1
- goto done_op
-func_sin:
- $N0 = l_arg
- $N1 = sin $N0
- op_result = $N1
- goto done_op
-func_sinh:
- $N0 = l_arg
- $N1 = sinh $N0
- op_result = $N1
- goto done_op
-func_sqrt:
- $N0 = l_arg
- $N1 = sqrt $N0
- op_result = $N1
- goto done_op
-func_tan:
- $N0 = l_arg
- $N1 = tan $N0
- op_result = $N1
- goto done_op
-func_tanh:
- $N0 = l_arg
- $N1 = tanh $N0
- op_result = $N1
- # fallthrough to done_op
+ # goto done_op
done_op:
$P5 = new FixedPMCArray
@@ -704,9 +612,13 @@ loop_done:
$P1 = find_global "_Tcl", "functions"
func = $P1[$S0]
- if_null func, fail
- $I0 = typeof func
- if $I0 == .Undef goto fail
+ if_null func, fail
+
+ $I0 = find_type "TclFunc"
+ func = new $I0
+ $P0 = new String
+ $P0 = $S0
+ setattribute func, "TclFunc\x00name", $P0
# and the operand is what's between the ()'s - get the result
# of /that/ expression and return it.
@@ -719,26 +631,21 @@ loop_done:
len_operand = $I1
$S1 = substr expr, start_paren_pos, len_operand
- # XXX should be checking return value here.
- ($I9,operand) = __expression_parse($S1)
- ($I9,operand) = __expression_interpret(operand)
- $P10 = new FixedPMCArray
- $P10 = 2
- $P10[0] = OPERAND
- $P10[1] = operand
- operand = $P10
+ ($I9,operand) = __expression_parse($S1)
if $I9 == TCL_ERROR goto fail
+
+ setattribute func, "TclFunc\x00argument", operand
- len = start_paren_pos + len_operand
+ len = start_paren_pos + len_operand
inc len
- len = len - start
+ len -= start
goto done
fail:
len = 0
done:
- .return(len,func,operand)
+ .return(len,func)
.end
=head2 _Tcl::__get_call_level
Added: trunk/languages/tcl/lib/tclfunc.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/tclfunc.pir Sat Aug 20 11:14:56 2005
@@ -0,0 +1,160 @@
+.namespace [ "TclFunc" ]
+
+.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
+
+# functions
+ .const int FUNCTION_ABS = 53
+ .const int FUNCTION_ACOS = 54
+ .const int FUNCTION_ASIN = 55
+ .const int FUNCTION_ATAN = 56
+ .const int FUNCTION_COS = 57
+ .const int FUNCTION_COSH = 58
+ .const int FUNCTION_EXP = 59
+ .const int FUNCTION_LOG = 60
+ .const int FUNCTION_LOG10 = 61
+ .const int FUNCTION_ROUND = 62
+ .const int FUNCTION_SIN = 63
+ .const int FUNCTION_SINH = 64
+ .const int FUNCTION_SQRT = 65
+ .const int FUNCTION_TAN = 66
+ .const int FUNCTION_TANH = 67
+ .const int FUNCTION_RAND = 68
+
+=head2 __class_init
+
+Define the attributes required for the class.
+
+=cut
+
+.sub __class_init @LOAD
+ $P0 = newclass "TclFunc"
+ addattribute $P0, "argument"
+ addattribute $P0, "name"
+.end
+
+=head2 __init
+
+Initialize the attributes for an instance of the class
+
+=cut
+
+.sub __init method
+ $P0 = new TclString
+ setattribute self, "TclFunc\x00name", $P0
+ $P0 = new TclString
+ setattribute self, "TclFunc\x00argument", $P0
+.end
+
+.sub interpret method
+ .local pmc retval
+ .local int return_type
+ # assigning a $Nx will change this to a TclFloat
+ retval = new TclInt
+ return_type = TCL_OK
+
+ .local pmc funcs, expr_interpret
+ funcs = find_global "_Tcl", "functions"
+ expr_interpret = find_global "_Tcl", "__expression_interpret"
+
+ .local pmc arg, name
+ arg = getattribute self, "TclFunc\x00argument"
+ (return_type, retval) = expr_interpret(arg)
+ if return_type == TCL_ERROR goto done
+ arg = retval
+ name = getattribute self, "TclFunc\x00name"
+
+ $I0 = funcs[name]
+ if $I0 == FUNCTION_ABS goto func_abs
+ if $I0 == FUNCTION_ACOS goto func_acos
+ if $I0 == FUNCTION_ASIN goto func_asin
+ if $I0 == FUNCTION_ATAN goto func_atan
+ if $I0 == FUNCTION_COS goto func_cos
+ if $I0 == FUNCTION_COSH goto func_cosh
+ if $I0 == FUNCTION_EXP goto func_exp
+ if $I0 == FUNCTION_LOG goto func_log
+ if $I0 == FUNCTION_LOG10 goto func_log10
+ if $I0 == FUNCTION_SIN goto func_sin
+ if $I0 == FUNCTION_SINH goto func_sinh
+ if $I0 == FUNCTION_SQRT goto func_sqrt
+ if $I0 == FUNCTION_TAN goto func_tan
+ if $I0 == FUNCTION_TANH goto func_tanh
+
+func_abs:
+ retval = abs arg
+ goto done
+func_acos:
+ $N0 = arg
+ $N1 = acos $N0
+ retval = $N1
+ goto done
+func_asin:
+ $N0 = arg
+ $N1 = asin $N0
+ retval = $N1
+ goto done
+func_atan:
+ $N0 = arg
+ $N1 = atan $N0
+ retval = $N1
+ goto done
+func_cos:
+ $N0 = arg
+ $N1 = cos $N0
+ retval = $N1
+ goto done
+func_cosh:
+ $N0 = arg
+ $N1 = cosh $N0
+ retval = $N1
+ goto done
+func_exp:
+ $N0 = arg
+ $N1 = exp $N0
+ retval = $N1
+ goto done
+func_log:
+ $N0 = arg
+ $N1 = ln $N0
+ retval = $N1
+ goto done
+func_log10:
+ $N0 = arg
+ $N1 = log10 $N0
+ retval = $N1
+ goto done
+func_sin:
+ $N0 = arg
+ $N1 = sin $N0
+ retval = $N1
+ goto done
+func_sinh:
+ $N0 = arg
+ $N1 = sinh $N0
+ retval = $N1
+ goto done
+func_sqrt:
+ $N0 = arg
+ $N1 = sqrt $N0
+ retval = $N1
+ goto done
+func_tan:
+ $N0 = arg
+ $N1 = tan $N0
+ retval = $N1
+ goto done
+func_tanh:
+ $N0 = arg
+ $N1 = tanh $N0
+ retval = $N1
+ # goto done
+
+done:
+ .return(return_type, retval)
+.end
Modified: trunk/languages/tcl/tcl.pir_template
==============================================================================
--- trunk/languages/tcl/tcl.pir_template (original)
+++ trunk/languages/tcl/tcl.pir_template Sat Aug 20 11:14:56 2005
@@ -24,7 +24,6 @@ providing a compreg-compatible method.
# so there's no conflict.
.const int OP = 20
- .const int FUNC = 21
.const int OPERAND = 11
# Still not sure if these are going to be useful
@@ -86,6 +85,7 @@ providing a compreg-compatible method.
# Load any dependant libraries.
load_bytecode "languages/tcl/lib/tclcommand.pbc"
load_bytecode "languages/tcl/lib/tclconst.pbc"
+ load_bytecode "languages/tcl/lib/tclfunc.pbc"
load_bytecode "languages/tcl/lib/tclvar.pbc"
load_bytecode "languages/tcl/lib/tclword.pbc"
load_bytecode "library/Data/Escape.pbc"
Modified: trunk/languages/tcl/tcl.pl
==============================================================================
--- trunk/languages/tcl/tcl.pl (original)
+++ trunk/languages/tcl/tcl.pl Sat Aug 20 11:14:56 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|command|const|var|word).pir$/} readdir(LIBDIR);
+my @libs = map {"$lib_dir/$_"} grep {m/\.pir$/} grep {!
m/^tcl(lib|command|const|func|var|word).pir$/} readdir(LIBDIR);
closedir(LIBDIR);
my $includes;
