Author: leo
Date: Sat Aug 13 04:48:47 2005
New Revision: 8938
Modified:
branches/leo-ctx5/config/gen/makefiles/root.in
branches/leo-ctx5/jit/sun4/jit_emit.h
branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t
branches/leo-ctx5/languages/tcl/classes/tclfloat.pmc
branches/leo-ctx5/languages/tcl/lib/expression.pir
branches/leo-ctx5/languages/tcl/lib/list.pir
branches/leo-ctx5/languages/tcl/lib/string.pir
branches/leo-ctx5/languages/tcl/t/cmd_expr.t
branches/leo-ctx5/languages/tcl/t/cmd_llength.t
branches/leo-ctx5/t/library/dumper.t
Log:
merge -r8925:8937 from trunk
Modified: branches/leo-ctx5/config/gen/makefiles/root.in
==============================================================================
--- branches/leo-ctx5/config/gen/makefiles/root.in (original)
+++ branches/leo-ctx5/config/gen/makefiles/root.in Sat Aug 13 04:48:47 2005
@@ -595,8 +595,9 @@ help :
@echo " Valid cores are b, C, f, g, j, r, S."
@echo " src_tests: Run test in C-file."
@echo " perl_tests: Test the Perl modules in the distribution."
+ @echo " testexex: Testing the exex runcore."
@echo " testbench: Run all benchmarks."
- @echo " manitest: Check for new files."
+ @echo " manitest: Check for new and missing files."
@echo ""
@echo "Benchmarks:"
@echo " mopsbench: Million operations"
@@ -1401,7 +1402,7 @@ reconfig : clean
$(PERL) Configure.pl --reconfig
manitest :
- $(PERL) "-MExtUtils::Manifest=fullcheck" -e fullcheck
+ $(PERL) tools/dev/manicheck.pl
###############################################################################
#
@@ -1515,8 +1516,3 @@ tags: tags.dummy
$(PERL) editor/addtags ops/*.ops
tags.dummy:
-
-# test the EXEC stuff
-
-testexec: hello
-
Modified: branches/leo-ctx5/jit/sun4/jit_emit.h
==============================================================================
--- branches/leo-ctx5/jit/sun4/jit_emit.h (original)
+++ branches/leo-ctx5/jit/sun4/jit_emit.h Sat Aug 13 04:48:47 2005
@@ -370,6 +370,9 @@ Parrot_jit_bytejump(Parrot_jit_info_t *j
Interp *interpreter, int reg_num)
{
+ /* fixup where we have the Parrot registers - context switches */
+ emitm_ld_i(jit_info->native_ptr, emitm_i(0), offsetof(Interp, ctx.bp),
Parrot_jit_regbase);
+
/* Construct the starting address of the byte code */
emitm_sethi(jit_info->native_ptr, emitm_hi22(interpreter->code->base.data),
XSR1);
Modified: branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t
==============================================================================
--- branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t (original)
+++ branches/leo-ctx5/languages/m4/t/builtins/010_sysval.t Sat Aug 13
04:48:47 2005
@@ -24,7 +24,7 @@ OUT
{
language_output_is( 'm4', <<'CODE', <<'OUT', 'output of "true"' );
-syscmd(`$true')
+syscmd(`$true`)
sysval()
CODE
Modified: branches/leo-ctx5/languages/tcl/classes/tclfloat.pmc
==============================================================================
--- branches/leo-ctx5/languages/tcl/classes/tclfloat.pmc (original)
+++ branches/leo-ctx5/languages/tcl/classes/tclfloat.pmc Sat Aug 13
04:48:47 2005
@@ -11,42 +11,47 @@
*/
#include "parrot/parrot.h"
+#include <assert.h>
pmclass TclFloat extends TclObject extends Float dynpmc group tcl_group {
STRING* get_string () {
- char* buff = mem_sys_allocate(80);
- int buflen,checklen;
+ UINTVAL buflen;
int check_flag;
+ STRING * buff;
+ STRING * dot;
+ STRING * dot_zero;
+
+ buff = Parrot_sprintf_c(INTERP, "%.12vg",PMC_num_val(SELF));
+
+ /*
+ * this sprintf variant will return something that looks like
+ * an int if it can : if we have no decimal point then tack on
+ * on and return
+ */
+ dot = string_from_cstring(INTERP,".",1);
+
+ if (string_str_index(INTERP,buff,dot,0) == -1 ) {
+ dot_zero = string_from_cstring(INTERP,".0",2);
+ buff = string_append(INTERP, buff, dot_zero,0);
+ return buff;
+ }
- STRING* s;
-#ifdef HAS_SNPRINTF
- snprintf(buff,80,FLOATVAL_FMT,PMC_num_val(SELF));
-#else
- sprintf(buff,FLOATVAL_FMT,PMC_num_val(SELF)); /* XXX buffer overflow!
*/
-#endif
- check_flag = 1;
- checklen = buflen = strlen(buff);
- while (check_flag && buflen) {
- if (buff[buflen-1] == 48) { /* 0 */
+ check_flag = 0;
+ buflen = string_length(INTERP,buff);
+ while (buflen) {
+ if (string_index(INTERP,buff,buflen-1) == '0') {
buflen--;
- } else {
- check_flag = 0;
+ check_flag = 1;
+ } else {
+ break;
}
}
- /* if the last entry is now a ".", then add one zero back in. */
- if (buff[buflen-1] == 46) {
- buflen++;
- }
- /* paranoid? */
- if (buflen > checklen) {
- buflen = checklen;
- }
- buff[buflen] = 0; /* should this be necessary? */
- s = string_make(INTERP,buff,buflen,"iso-8859-1",0);
- mem_sys_free(buff);
- return s;
+ /* truncate the string */
+ buff->strlen = buflen;
+ buff->bufused = buflen;
+ return buff;
}
}
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 Sat Aug 13 04:48:47 2005
@@ -18,7 +18,6 @@ however, then we're returning the invoka
.sub __expression_parse
.param string expr
- .param pmc foo
.local pmc retval
.local int return_type
@@ -30,7 +29,6 @@ however, then we're returning the invoka
.local pmc precedences # Global list of operator precedence
precedences = find_global "_Tcl", "precedence"
-got_arg:
.local pmc undef
undef = new Undef
@@ -40,46 +38,40 @@ got_arg:
program_stack = new TclList
.local int chunk_start
- chunk_start = 0
- .local int chunk_end
- chunk_end = 0
+ chunk_start = -1 # we inc before we use it
+
.local int char
.local int expr_length
expr_length = length expr
-
- #print "CALLED WITH "
- #print expr
-
-# Split the string into an array of chunks
-# right now we're just handling integer operands. that's it.
-
.local int op_length
chunk_loop:
- #print "CHUNK_LOOP\n"
+ inc chunk_start
if chunk_start >= expr_length goto chunks_done
- # Is this a space? skip it and try again, otherwise, fall through.
$I0 = is_whitespace expr, chunk_start
- if $I0 == 0 goto get_parenthetical
-
- inc chunk_start
- inc chunk_end
- goto chunk_loop
+ if $I0 == 1 goto chunk_loop
+
+ $I0 = is_digit expr, chunk_start
+ if $I0 == 1 goto get_number
+
+ $I0 = ord expr, chunk_start
+ if $I0 == 40 goto get_parenthetical # (
+ if $I0 == 36 goto get_variable # $
+ if $I0 == 46 goto get_number # .
+
+ $I0 = is_wordchar expr, chunk_start
+ if $I0 == 1 goto get_function
+
+ goto get_operator
get_parenthetical:
- # are we on an open paren? then figure out what's inside the
- # string and call ourselves recursively.
- # (XXX should unroll this recursion.)
-
- char = ord expr, chunk_start
- 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
+ if $I1 >= expr_length goto premature_end
$I0 = ord expr, $I1
if $I0 == 41 goto get_paren_loop_right
if $I0 == 40 goto get_paren_loop_left
@@ -114,7 +106,6 @@ get_paren_done:
push chunks, chunk
chunk_start += $I0
- inc chunk_start
goto chunk_loop
get_variable:
@@ -156,7 +147,7 @@ get_variable_continue:
push chunks, chunk
chunk_start = chunk_start + op_length
-
+ dec chunk_start
goto chunk_loop
get_function:
@@ -174,7 +165,8 @@ get_function:
chunk[2] = -1 # functions trump operands, for now.
push chunks, chunk
push chunks, result
- chunk_start = chunk_start + op_length
+ chunk_start += op_length
+ dec chunk_start
goto chunk_loop
get_number:
@@ -187,8 +179,12 @@ get_number:
if op_length == 0 goto get_operator
# XXX otherwise, pull that number off
# stuff the chunk onto the chunk_list
- push chunks, value
- chunk_start = chunk_start + op_length
+ chunk = new TclList
+ chunk[0] = INTEGER
+ chunk[1] = value
+ push chunks, chunk
+ chunk_start += op_length
+ dec chunk_start
goto chunk_loop
get_operator:
@@ -243,8 +239,8 @@ op_done:
push chunks, chunk
- chunk_start = chunk_start + op_len
-
+ chunk_start += op_len
+ dec chunk_start
goto chunk_loop
# if we don't match any of the possible cases so far, then we must
@@ -353,6 +349,14 @@ die_horribly:
return_type = TCL_ERROR
program_stack = new String
program_stack = "An error occurred in EXPR"
+ goto converter_done
+
+premature_end:
+ return_type = TCL_ERROR
+ program_stack = new String
+ program_stack = "syntax error in expression \""
+ program_stack .= expr
+ program_stack .= "\": premature end of expression"
converter_done:
#print "converter done\n"
@@ -735,9 +739,8 @@ failure:
finish_up:
$S0 = substr expr, start, pos
$I0 = $S0
- value = new TclList
- value[0] = INTEGER
- value[1] = $I0
+ value = new TclInt
+ value = $I0
real_done:
.return(pos,INTEGER,value)
@@ -950,7 +953,6 @@ was this a valid tcl-style level, or did
.sub __get_call_level
.param pmc tcl_level
.local pmc parrot_level, defaulted, orig_level
- parrot_level = new Integer
defaulted = new Integer
defaulted = 0
@@ -959,7 +961,6 @@ was this a valid tcl-style level, or did
orig_level = current_call_level
.local int num_length, num_type
- .local pmc num_result
get_absolute:
# Is this an absolute?
@@ -967,25 +968,23 @@ get_absolute:
$S1 = substr $S0, 0, 1
if $S1 != "#" goto get_integer
$S0 = tcl_level
- (num_length,num_type,num_result) = __expr_get_number($S0,1)
+ (num_length,num_type,parrot_level) = __expr_get_number($S0,1)
if num_type != INTEGER goto default
$S0 = tcl_level
$I0 = length $S0
dec $I0
if $I0 != num_length goto default
- parrot_level = num_result[1]
goto bounds_check
get_integer:
# Is this an integer?
$S0 = tcl_level
- (num_length,num_type,num_result) = __expr_get_number($S0,0)
+ (num_length,num_type,parrot_level) = __expr_get_number($S0,0)
if num_type != INTEGER goto default
$S0 = tcl_level
$I0 = length $S0
if $I0 != num_length goto default
- parrot_level = num_result[1]
parrot_level = orig_level - parrot_level
goto bounds_check
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 Sat Aug 13 04:48:47 2005
@@ -28,10 +28,9 @@
$S0 = substr position, 0, 4
if $S0 == "end-" goto has_end
index_length = length position
- (number_length,number_type,number_result) = __expr_get_number(position,0)
+ (number_length,number_type,retval) = __expr_get_number(position,0)
if number_type != INTEGER goto bad_arg
if number_length != index_length goto bad_arg
- retval = number_result[1]
# if the number is greater than the number of elements
# in the list, we want the end
@@ -60,7 +59,7 @@ has_end:
if number_type != INTEGER goto bad_arg
if number_length != index_length goto bad_arg
# say, 1 if -1
- $I0 = number_result[1]
+ $I0 = number_result
# say, 2 if -2
inc $I0
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 Sat Aug 13 04:48:47 2005
@@ -31,10 +31,9 @@
if $S0 == "end-" goto has_end
index_length = length $S0
# is this an int?
- (number_length,number_type,number_result) = __expr_get_number(position,0)
+ (number_length,number_type,retval) = __expr_get_number(position,0)
if number_type != INTEGER goto bad_arg
if number_length != index_length goto bad_arg
- retval = number_result[1]
goto done
#if not, fail.
@@ -55,7 +54,7 @@ has_end:
if number_type != INTEGER goto bad_arg
if number_length != index_length goto bad_arg
# say, 1 if -1
- $I0 = number_result[1]
+ $I0 = number_result
# say, 2 if -2
inc $I0
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 Sat Aug 13 04:48:47 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 43;
+use Parrot::Test tests => 44;
use vars qw($TODO);
language_output_is("tcl",<<TCL,<<OUT,"mul");
@@ -150,13 +150,6 @@ TCL
3
OUT
-#
-# now, functions - the accuracy and int vs. float nature here is
-# still an issue - we're testing to make sure that the functions
-# exist, basically. better tests will need to be written (or the tcl
-# test suite used.) (XXX)
-#
-
language_output_is("tcl",<<TCL,<<OUT,"abs");
puts [expr abs(1-2)]
TCL
@@ -166,61 +159,61 @@ OUT
language_output_is("tcl",<<TCL,<<OUT,"acos");
puts [expr acos(0)]
TCL
-1.570796
+1.57079632679
OUT
language_output_is("tcl",<<TCL,<<OUT,"asin");
puts [expr asin(1)]
TCL
-1.570796
+1.57079632679
OUT
language_output_is("tcl",<<TCL,<<OUT,"atan");
puts [expr atan(1)]
TCL
-0.785398
+0.785398163397
OUT
language_output_is("tcl",<<TCL,<<OUT,"cos");
puts [expr cos(1)]
TCL
-0.540302
+0.540302305868
OUT
language_output_is("tcl",<<TCL,<<OUT,"cosh");
puts [expr cosh(1)]
TCL
-1.543081
+1.54308063482
OUT
language_output_is("tcl",<<TCL,<<OUT,"exp");
puts [expr exp(1)]
TCL
-2.718282
+2.71828182846
OUT
language_output_is("tcl",<<TCL,<<OUT,"log");
puts [expr log(32)]
TCL
-3.465736
+3.4657359028
OUT
language_output_is("tcl",<<TCL,<<OUT,"log10");
puts [expr log10(32)]
TCL
-1.50515
+1.50514997832
OUT
language_output_is("tcl",<<TCL,<<OUT,"sin");
puts [expr sin(1)]
TCL
-0.841471
+0.841470984808
OUT
language_output_is("tcl",<<TCL,<<OUT,"sinh");
puts [expr sinh(1)]
TCL
-1.175201
+1.17520119364
OUT
language_output_is("tcl",<<TCL,<<OUT,"sqrt");
@@ -232,13 +225,13 @@ OUT
language_output_is("tcl",<<TCL,<<OUT,"tan");
puts [expr tan(1)]
TCL
-1.557408
+1.55740772465
OUT
language_output_is("tcl",<<TCL,<<OUT,"tanh");
puts [expr tanh(1)]
TCL
-0.761594
+0.761594155956
OUT
# misc.
@@ -255,6 +248,12 @@ TCL
28
OUT
+language_output_is("tcl",<<'TCL',<<'OUT',"premature end of expr '('");
+ puts [expr "("]
+TCL
+syntax error in expression "(": premature end of expression
+OUT
+
TODO: {
local $TODO = "bugs";
@@ -264,7 +263,7 @@ TCL
0.333333333333
OUT
-language_output_is("tcl",<<'TCL',<<'OUT',"int vs. float");
+language_output_is("tcl",<<'TCL',<<'OUT',"braced operands.");
set n 1
puts [expr {$n * 1}]
TCL
Modified: branches/leo-ctx5/languages/tcl/t/cmd_llength.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/cmd_llength.t (original)
+++ branches/leo-ctx5/languages/tcl/t/cmd_llength.t Sat Aug 13 04:48:47 2005
@@ -3,7 +3,6 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
use Parrot::Test tests => 5;
-use vars qw($TODO);
language_output_is("tcl",<<'TCL',<<OUT,"no elements");
puts [llength [list]]
Modified: branches/leo-ctx5/t/library/dumper.t
==============================================================================
--- branches/leo-ctx5/t/library/dumper.t (original)
+++ branches/leo-ctx5/t/library/dumper.t Sat Aug 13 04:48:47 2005
@@ -935,7 +935,7 @@ OUTPUT
# no. 27
pir_output_is(<<'CODE', <<'OUTPUT', "custom dumper");
.sub main @MAIN
- .local pmc o, ds, cl
+ .local pmc o, cl
cl = subclass 'ResizablePMCArray', 'bar'
.local int id
id = typeof cl
