diff --git a/lisp/expt.lisp b/lisp/expt.lisp index 433b0ea..7ec849e 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,4 +5,5 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(expt 2 60) +(inspect expt) +(expt 2 59) diff --git a/src/arith/integer.c b/src/arith/integer.c index 5b2e26a..9e1a8a0 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,7 +27,9 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "equal.h" #include "lispops.h" +#include "peano.h" /* * The maximum value we will allow in an integer cell. @@ -100,11 +102,11 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { /** * Internal to `operate_on_integers`, do not use. * @param c a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expectedto be either - * '+' or '*'; behaviour with other values is undefined. + * @param is_first_cell true if this is the first cell in a bignum + * chain, else false. * \see operate_on_integers */ -__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { +__int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; @@ -117,8 +119,8 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { val : 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", - val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); + L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", + val, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -126,60 +128,77 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { } /** - * internal workings of both `add_integers` and `multiply_integers` (and - * possibly, later, other operations. Apply the operator `op` to the - * integer arguments `a` and `b`, and return a pointer to the result. If - * either `a` or `b` is not an integer, returns `NIL`. + * Overwrite the value field of the integer indicated by `new` with + * the least significant 60 bits of `val`, and return the more significant + * bits (if any) right-shifted by 60 places. Destructive, primitive, do not + * use in any context except primitive operations on integers. * - * @param a a pointer to a cell, assumed to be an integer cell; - * @param b a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expected to be either - * '+' or '*'; behaviour with other values is undefined. - * \see add_integers - * \see multiply_integers + * @param val the value to represent; + * @param less_significant the less significant words of this bignum, if any, + * else NIL; + * @param new a newly created integer, which will be destructively changed. + * @return carry, if any, else 0. */ -/* \todo there is a significant bug here, which manifests in multiply but - * may not manifest in add. The value in the least significant cell ends - * up significantly WRONG, but the value in the more significant cell - * ends up correct. */ -struct cons_pointer operate_on_integers( struct cons_pointer a, - struct cons_pointer b, char op ) { +__int128_t int128_to_integer( __int128_t val, + struct cons_pointer less_significant, + struct cons_pointer new) +{ + struct cons_pointer cursor = NIL; + __int128_t carry = 0; + + if ( MAX_INTEGER >= val ) { + carry = 0; + } else { + carry = val >> 60; + debug_printf( DEBUG_ARITH, + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + val &= MAX_INTEGER; + } + + struct cons_space_object * newc = &pointer2cell( new); + newc->payload.integer.value = val; + + if ( integerp( less_significant ) ) { + struct cons_space_object *lsc = &pointer2cell( less_significant ); + inc_ref( new ); + lsc->payload.integer.more = new; + } + + return carry; +} + +/** + * Return a pointer to an integer representing the sum of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; + debug_print( L"add_integers: a = ", DEBUG_ARITH ); + debug_print_object(a, DEBUG_ARITH); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + __int128_t carry = 0; bool is_first_cell = true; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); + debug_print( L"add_integers: \n", DEBUG_ARITH ); debug_dump_object( a, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L" %c \n", op ); + debug_print( L" plus \n", DEBUG_ARITH ); debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, op, is_first_cell ); - __int128_t bv = cell_value( b, op, is_first_cell ); + __int128_t av = cell_value( a, is_first_cell ); + __int128_t bv = cell_value( b, is_first_cell ); + __int128_t rv = av + bv + carry; - /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and - * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry - * is very large (which I'm not certain whether it can be and am not - * intellectually up to proving it this morning) adding the carry might - * overflow `__int128_t`. Edge-case testing required. - */ - __int128_t rv = NAN; - - switch ( op ) { - case '*': - rv = (av * bv) + carry; - break; - case '+': - rv = av + bv + carry; - break; - } - - debug_printf( DEBUG_ARITH, - L"operate_on_integers: op = '%c'; av = ", op ); + debug_print( L"add_integers: av = ", DEBUG_ARITH ); debug_print_128bit( av, DEBUG_ARITH ); debug_print( L"; bv = ", DEBUG_ARITH ); debug_print_128bit( bv, DEBUG_ARITH ); @@ -189,31 +208,9 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, debug_print_128bit( rv, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); - - if ( MAX_INTEGER >= rv ) { - carry = 0; - } else { - // \todo we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv &= MAX_INTEGER; - } - - struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - - if ( nilp( cursor ) ) { - cursor = tail; - } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; - cursor = tail; - } + struct cons_pointer new = make_integer( 0, NIL); + carry = int128_to_integer(rv, cursor, new); + cursor = new; if ( nilp( result ) ) { result = cursor; @@ -225,30 +222,111 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, } } - debug_print( L"operate_on_integers returning:\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; } -/** - * Return a pointer to an integer representing the sum of the integers - * pointed to by `a` and `b`. If either isn't an integer, will return nil. - */ -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ) { +struct cons_pointer base_partial(int depth) { + struct cons_pointer result = NIL; - return operate_on_integers( a, b, '+' ); + for (int i = 0; i < depth; i++) { + result = make_integer(0, result); + } + + return result; } /** * Return a pointer to an integer representing the product of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. + * \todo it is MUCH more complicated than this! + * + * @param a an integer; + * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers( a, b, '*' ); + struct cons_pointer result = NIL; + bool neg = is_negative(a) != is_negative(b); + bool is_first_b = true; + int oom = 0; + + debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); + debug_print_object(a, DEBUG_ARITH); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( b ) ) { + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial(oom++); + __int128_t carry = 0; + + while ( !nilp(d) || carry != 0) { + struct cons_pointer old_partial = partial; + struct cons_pointer new = make_integer( 0, NIL); + __int128_t dv = cell_value( d, is_first_d ); + __int128_t bv = cell_value( b, is_first_b ); + + __int128_t rv = (dv * bv) + carry; + + debug_print( L"multiply_integers: d = ", DEBUG_ARITH); + debug_print_object( d, DEBUG_ARITH); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH); + debug_print( L"\n", DEBUG_ARITH ); + + inc_ref(new); + carry = int128_to_integer(rv, NIL, new); + + if (nilp(d) && carry != 0) debug_print(L"THIS SHOULD NEVER HAPPEN!\n", DEBUG_ARITH); + + if (nilp(partial) || zerop(partial)) { + partial = new; + } else { + partial = add_integers(partial, new); + inc_ref(partial); + //dec_ref(new); + } + + //dec_ref(old_partial); + d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; + is_first_d = false; + } + + if (nilp(result) || zerop(result)) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers(partial, result); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; + } + } + + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; } /** @@ -325,7 +403,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, * an unwanted comma on the front. */ struct cons_pointer tmp = result; result = pointer2cell( result ).payload.string.cdr; - dec_ref( tmp ); + //dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index 6666d0e..85bbd5c 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -57,6 +57,51 @@ bool zerop( struct cons_pointer arg ) { return result; } +/** + * does this `arg` point to a negative number? + */ +bool is_negative( struct cons_pointer arg) { + bool result = false; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value < 0; + break; + case RATIOTV: + result = is_negative( cell.payload.ratio.dividend ); + break; + case REALTV: + result = ( cell.payload.real.value < 0 ); + break; + } + + return result; +} + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + if ( is_negative( arg)) { + switch ( cell.tag.value ) { + case INTEGERTV: + result = make_integer(llabs(cell.payload.integer.value), cell.payload.integer.more); + break; + case RATIOTV: + result = make_ratio(frame_pointer, + absolute(frame_pointer, cell.payload.ratio.dividend), + cell.payload.ratio.divisor); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } + } + + return result; +} + /** * Return the closest possible `binary64` representation to the value of * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` @@ -136,6 +181,22 @@ int64_t to_long_int( struct cons_pointer arg ) { } +/** + * Function: calculate the absolute value of a number. + * + * (absolute arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return the absolute value of the number represented by the first + * argument, or NIL if it was not a number. + */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame_pointer, frame->arg[0]); +} + /** * return a cons_pointer indicating a number which is the sum of * the numbers indicated by `arg1` and `arg2`. @@ -286,7 +347,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, debug_print_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")", DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -316,9 +377,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - frame_pointer ); + result = throw_exception( make_cons( + c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ), + c_type(arg2)), + frame_pointer ); break; } break; @@ -342,8 +404,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), + result = throw_exception( + make_cons(c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type(arg2)), frame_pointer ); } break; @@ -353,20 +417,24 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = throw_exception( + make_cons(c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type(arg1)), + frame_pointer ); break; } } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"multiply_2 returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); return result; } +#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}} + /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -381,29 +449,31 @@ struct cons_pointer lisp_multiply( struct struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) - && !exceptionp( result ); i++ ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); + for ( int i = 0; + i < args_in_frame + && !nilp( frame->arg[i] ) + && !exceptionp( result ); + i++ ) { + debug_print( L"lisp_multiply: accumulator = ",DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_print( L"; arg = ", DEBUG_ARITH); + debug_print_object(frame->arg[i], DEBUG_ARITH); + debug_println( DEBUG_ARITH); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } + multiply_one_arg(frame->arg[i]); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, c_car( more ) ); - - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - + multiply_one_arg(c_car( more )); more = c_cdr( more ); } + debug_print( L"lisp_multiply returning: ",DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + return result; } @@ -445,6 +515,24 @@ struct cons_pointer negative( struct cons_pointer frame, return result; } + +/** + * Function: is this number negative? + * + * * (negative? arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return T if the first argument was a negative number, or NIL if it + * was not. + */ +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative(frame->arg[0]) ? TRUE : NIL; +} + + /** * return a cons_pointer indicating a number which is the result of * subtracting the number indicated by `arg2` from that indicated by `arg1`, diff --git a/src/arith/peano.h b/src/arith/peano.h index 816b147..fa03212 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -17,66 +17,40 @@ bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -/** - * \todo cannot throw an exception out of here, which is a problem. - * if a ratio may legally have zero as a divisor, or something which is - * not a number is passed in. - */ +bool is_negative( struct cons_pointer arg); + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg); + long double to_long_double( struct cons_pointer arg ); -/** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); + struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * Multiply an indefinite number of numbers together. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); + struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * return a cons_pointer indicating a number which is the - * 0 - the number indicated by `arg`. - */ struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -/** - * return a cons_pointer indicating a number which is the result of - * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, - * in the context of this `frame`. - */ struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -/** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * Divide one number by another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/init.c b/src/init.c index 7fdad2d..e0d2b01 100644 --- a/src/init.c +++ b/src/init.c @@ -142,6 +142,7 @@ int main( int argc, char *argv[] ) { /* * primitive function operations */ + bind_function( L"absolute", &lisp_absolute ); bind_function( L"add", &lisp_add ); bind_function( L"apply", &lisp_apply ); bind_function( L"assoc", &lisp_assoc ); @@ -155,6 +156,7 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); + bind_function( L"negative?", &lisp_is_negative); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist );