+ bignums:\r
\r
-- -1 is broken, add a test to verify this in the future\r
-- gcd is broken\r
-- bignum/ is broken\r
- change shift< and shift> to ash\r
-- gcd is broken\r
- cached 0/-1/1 should be cross compiled in image\r
- bignum cross compiling\r
-- upgrading fixnums does not work\r
+- upgrading fixnums does not work with shift</shift>\r
- ash is inefficient: arg 2 is upgraded to bignum then back\r
to long\r
- move some s48_ functions into bignum.c\r
- remove unused functions\r
-\r
+- clean up type coercions in arithmetic.c\r
- add a socket timeout\r
+\r
- >lower, >upper for strings\r
- telnetd should use multitasking\r
- accept multi-line input in listener\r
+ native:\r
\r
- is the profiler using correct stack depth?\r
-- bignums\r
- read1\r
- sbuf-hashcode\r
- vector-hashcode\r
DEFER: str=
DEFER: str-hashcode
DEFER: sbuf=
-DEFER: clone-sbuf
+DEFER: sbuf-clone
IN: io-internals
DEFER: port?
set-sbuf-nth
sbuf-append
sbuf>str
- clone-sbuf
+ sbuf-reverse
+ sbuf-clone
sbuf=
number?
>fixnum
: sbuf>str ( sbuf -- str )
>str ;
+
+: sbuf-reverse ( sbuf -- )
+ #! Destructively reverse a string buffer.
+ [ ] "java.lang.StringBuffer" "reverse" jinvoke drop ;
: clone ( obj -- obj )
[
[ cons? ] [ clone-list ]
- [ vector? ] [ clone-vector ]
- [ sbuf? ] [ clone-sbuf ]
+ [ vector? ] [ vector-clone ]
+ [ sbuf? ] [ sbuf-clone ]
[ drop t ] [ ( return the object ) ]
] cond ;
USE: strings
USE: words
-: integer% ( num -- )
- "base" get /mod swap dup 0 > [
- integer%
+: integer% ( num radix -- )
+ tuck /mod >digit % dup 0 > [
+ swap integer%
] [
- drop
- ] ifte >digit % ;
+ 2drop
+ ] ifte ;
: integer- ( num -- num )
dup 0 < [ "-" % neg ] when ;
: >base ( num radix -- string )
#! Convert a number to a string in a certain base.
- [ "base" set <% integer- integer% %> ] with-scope ;
+ <% dup 0 < [
+ neg integer% CHAR: - %
+ ] [
+ integer%
+ ] ifte reverse%> ;
: >dec ( num -- string )
#! Convert an integer to its decimal representation.
#! stack.
"string-buffer" get sbuf>str n> drop ;
+: reverse%> ( -- str )
+ #! Ends construction and pushes the *reversed*, constructed
+ #! text on the stack.
+ "string-buffer" get dup sbuf-reverse sbuf>str n> drop ;
+
: fill ( count char -- string )
#! Push a string that consists of the same character
#! repeated.
--- /dev/null
+IN: scratchpad
+USE: math
+USE: stack
+USE: test
+
+[ 30000 fac drop ] time
IN: scratchpad
USE: math
+USE: stack
USE: test
-[ 35 fib ] time
+[ 35 fib drop ] time
--- /dev/null
+IN: scratchpad
+USE: arithmetic
+USE: stack
+USE: test
+USE: unparser
+
+[ -1 ] [ -1 >bignum >fixnum ] unit-test
+
+[ "8589934592" ]
+[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
+unit-test
--- /dev/null
+IN: scratchpad
+USE: arithmetic
+USE: test
+
+[ 100 ] [ 100 100 gcd ] unit-test
+[ 100 ] [ 1000 100 gcd ] unit-test
+[ 100 ] [ 100 1000 gcd ] unit-test
+[ 4 ] [ 132 64 gcd ] unit-test
+[ 4 ] [ -132 64 gcd ] unit-test
+[ 4 ] [ -132 -64 gcd ] unit-test
+[ 4 ] [ 132 -64 gcd ] unit-test
+[ 4 ] [ -132 -64 gcd ] unit-test
+
+[ 100 ] [ 100 >bignum 100 >bignum gcd ] unit-test
+[ 100 ] [ 1000 >bignum 100 >bignum gcd ] unit-test
+[ 100 ] [ 100 >bignum 1000 >bignum gcd ] unit-test
+[ 4 ] [ 132 >bignum 64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum 64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
+[ 4 ] [ 132 >bignum -64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
[ t ]
[ 1000000000000/999999999999 1000000000001/999999999998 < ]
unit-test
-
-[ 100 ] [ 100 100 gcd ] unit-test
-[ 100 ] [ 1000 100 gcd ] unit-test
-[ 100 ] [ 100 1000 gcd ] unit-test
-[ 4 ] [ 132 64 gcd ] unit-test
-[ 4 ] [ -132 64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test
-[ 4 ] [ 132 -64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test
USE: combinators
USE: kernel
USE: namespaces
+USE: stack
USE: strings
USE: test
[ t ] [ "abc" "abd" str-compare 0 < ] unit-test
[ t ] [ "z" "abd" str-compare 0 > ] unit-test
+[ "fedcba" ] [ "abcdef" str>sbuf dup sbuf-reverse sbuf>str ] unit-test
+[ "edcba" ] [ "abcde" str>sbuf dup sbuf-reverse sbuf>str ] unit-test
+
native? [
[ t ] [ "Foo" str>sbuf "Foo" str>sbuf = ] unit-test
[ f ] [ "Foo" str>sbuf "Foob" str>sbuf = ] unit-test
"words"
"unparser"
"random"
+ "math/bignum"
"math/bitops"
+ "math/gcd"
"math/rational"
"math/float"
"math/complex"
DEFER: vector-map
-: clone-vector ( vector -- vector )
+: vector-clone ( vector -- vector )
#! Shallow copy of a vector.
[ ] vector-map ;
#define CELL_TO_INTEGER(result) \
FIXNUM _result = (result); \
- /* if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
- return tag_object(fixnum_to_bignum(_result)); \
+ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
+ return tag_object(s48_long_to_bignum(_result)); \
else \
- */return tag_fixnum(_result);
-
-#define BIGNUM_2_TO_INTEGER(result) \
- BIGNUM_2 _result = (result); \
- /* if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
- return tag_object(s48_long_to_bignum(_result)); \
- else \
- */return tag_fixnum(_result);
+ return tag_fixnum(_result);
#define BINARY_OP(OP) \
CELL OP(CELL x, CELL y) \
bignum_pos_one = bignum_allocate(1,0);
(BIGNUM_REF (bignum_pos_one, 0)) = 1;
- bignum_neg_one = bignum_allocate(1,0);
+ bignum_neg_one = bignum_allocate(1,1);
(BIGNUM_REF (bignum_neg_one, 0)) = 1;
}
return tag_object(s48_bignum_multiply(x,y));
}
-BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y)
+CELL gcd_bignum(ARRAY* x, ARRAY* y)
{
- BIGNUM_2 t;
+ ARRAY* t;
- if(x < 0)
- x = -x;
- if(y < 0)
- y = -y;
+ if(BIGNUM_NEGATIVE_P(x))
+ x = s48_bignum_negate(x);
+ if(BIGNUM_NEGATIVE_P(y))
+ y = s48_bignum_negate(y);
- if(x > y)
+ if(s48_bignum_compare(x,y) == bignum_comparison_greater)
{
t = x;
x = y;
for(;;)
{
- if(x == 0)
- return y;
+ if(BIGNUM_ZERO_P(x))
+ return tag_object(y);
- t = y % x;
+ t = s48_bignum_remainder(y,x);
y = x;
x = t;
}
CELL divide_bignum(ARRAY* x, ARRAY* y)
{
- /* BIGNUM_2 _x = x->n;
- BIGNUM_2 _y = y->n;
- BIGNUM_2 gcd;
+ ARRAY* gcd;
- if(_y == 0)
- {
- /* FIXME
- abort();
- }
- else if(_y < 0)
- {
- _x = -_x;
- _y = -_y;
- }
+ if(BIGNUM_ZERO_P(y))
+ raise(SIGFPE);
- gcd = gcd_bignum(_x,_y);
- if(gcd != 1)
+ if(BIGNUM_NEGATIVE_P(y))
{
- _x /= gcd;
- _y /= gcd;
+ x = s48_bignum_negate(x);
+ y = s48_bignum_negate(y);
}
- if(_y == 1)
- return tag_object(bignum(_x));
+ gcd = (ARRAY*)UNTAG(gcd_bignum(x,y));
+ x = s48_bignum_quotient(x,gcd);
+ y = s48_bignum_quotient(y,gcd);
+
+ if(BIGNUM_ONE_P(y,0))
+ return tag_object(x);
else
{
return tag_ratio(ratio(
- tag_object(bignum(_x)),
- tag_object(bignum(_y))));
- } */
- return F;
+ tag_object(x),
+ tag_object(y)));
+ }
}
CELL divint_bignum(ARRAY* x, ARRAY* y)
-typedef long long BIGNUM_2;
-
INLINE ARRAY* untag_bignum(CELL tagged)
{
type_check(BIGNUM_TYPE,tagged);
CELL add_bignum(ARRAY* x, ARRAY* y);
CELL subtract_bignum(ARRAY* x, ARRAY* y);
CELL multiply_bignum(ARRAY* x, ARRAY* y);
-BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y);
+CELL gcd_bignum(ARRAY* x, ARRAY* y);
CELL divide_bignum(ARRAY* x, ARRAY* y);
CELL divint_bignum(ARRAY* x, ARRAY* y);
CELL divfloat_bignum(ARRAY* x, ARRAY* y);
CELL_TO_INTEGER(untag_fixnum_fast(x) - untag_fixnum_fast(y));
}
-CELL multiply_fixnum(CELL x, CELL y)
+CELL multiply_fixnum(CELL _x, CELL _y)
{
- BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
- * (BIGNUM_2)untag_fixnum_fast(y));
+ FIXNUM x = untag_fixnum_fast(_x);
+ FIXNUM y = untag_fixnum_fast(_y);
+ long long result = (long long)x * (long long)y;
+ if(result < FIXNUM_MIN || result > FIXNUM_MAX)
+ {
+ return tag_object(s48_bignum_multiply(
+ s48_long_to_bignum(x),
+ s48_long_to_bignum(y)));
+ }
+ else
+ return tag_fixnum(result);
}
CELL divint_fixnum(CELL x, CELL y)
FIXNUM gcd;
if(_y == 0)
- {
- /* FIXME */
- abort();
- }
+ raise(SIGFPE);
else if(_y < 0)
{
_x = -_x;
CELL shiftleft_fixnum(CELL x, CELL y)
{
- BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
- << (BIGNUM_2)untag_fixnum_fast(y));
+ /* BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
+ << (BIGNUM_2)untag_fixnum_fast(y)); */
+ return F;
}
CELL shiftright_fixnum(CELL x, CELL y)
{
- BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
- >> (BIGNUM_2)untag_fixnum_fast(y));
+ /* BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
+ >> (BIGNUM_2)untag_fixnum_fast(y)); */
+ return F;
}
CELL less_fixnum(CELL x, CELL y)
void primitive_float_to_bits(void)
{
double f = untag_float(dpeek());
- BIGNUM_2 f_raw = *(BIGNUM_2*)&f;
+ long long f_raw = *(long long*)&f;
drepl(tag_object(s48_long_to_bignum(f_raw)));
}
primitive_set_sbuf_nth,
primitive_sbuf_append,
primitive_sbuf_to_string,
- primitive_clone_sbuf,
+ primitive_sbuf_reverse,
+ primitive_sbuf_clone,
primitive_sbuf_eq,
primitive_numberp,
primitive_to_fixnum,
extern XT primitives[];
-#define PRIMITIVE_COUNT 141
+#define PRIMITIVE_COUNT 142
CELL primitive_to_xt(CELL primitive);
s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
- return (BIGNUM_OUT_OF_BAND);
+ {
+ raise(SIGFPE);
+ return (BIGNUM_OUT_OF_BAND);
+ }
if (BIGNUM_ZERO_P (numerator))
return (BIGNUM_MAYBE_COPY (numerator));
{
s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
- return (BIGNUM_OUT_OF_BAND);
+ {
+ raise(SIGFPE);
+ return (BIGNUM_OUT_OF_BAND);
+ }
if (BIGNUM_ZERO_P (numerator))
return (BIGNUM_MAYBE_COPY (numerator));
switch (bignum_compare_unsigned (numerator, denominator))
0, 1, and -1. */
#define BIGNUM_ZERO() bignum_zero
#define BIGNUM_ONE(neg_p) \
- (neg_p ? bignum_pos_one : bignum_neg_one)
+ (neg_p ? bignum_neg_one : bignum_pos_one)
+
+#define BIGNUM_ONE_P(bignum,negative_p) ((bignum) == BIGNUM_ONE(negative_p))
#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
drepl(tag_object(sbuf_to_string(untag_sbuf(dpeek()))));
}
-void primitive_clone_sbuf(void)
+void primitive_sbuf_reverse(void)
+{
+ SBUF* sbuf = untag_sbuf(dpop());
+ int i, j;
+ CHAR ch1, ch2;
+ for(i = 0; i < sbuf->top / 2; i++)
+ {
+ j = sbuf->top - i - 1;
+ ch1 = string_nth(sbuf->string,i);
+ ch2 = string_nth(sbuf->string,j);
+ set_string_nth(sbuf->string,j,ch1);
+ set_string_nth(sbuf->string,i,ch2);
+ }
+}
+
+void primitive_sbuf_clone(void)
{
SBUF* s = untag_sbuf(dpeek());
SBUF* new_s = sbuf(s->top);
void primitive_sbuf_append(void);
STRING* sbuf_to_string(SBUF* sbuf);
void primitive_sbuf_to_string(void);
-void primitive_clone_sbuf(void);
+void primitive_sbuf_reverse(void);
+void primitive_sbuf_clone(void);
bool sbuf_eq(SBUF* s1, SBUF* s2);
void primitive_sbuf_eq(void);
void fixup_sbuf(SBUF* sbuf);