diff --git a/src/arith/integer.c b/src/arith/integer.c index 01fc8fb..5452107 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -521,3 +521,21 @@ bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { return result; } + +/** + * true if `a` is an integer, and `b` is a real number whose value is the + * value of that integer. + */ +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { + bool result = false; + + if ( integerp( a ) && realp( b ) ) { + long double bv = pointer2cell( b ).payload.real.value; + + if ( floor( bv ) == bv ) { + result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv; + } + } + + return result; +} diff --git a/src/arith/peano.c b/src/arith/peano.c index 1a43f55..ae23a00 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -748,29 +748,3 @@ struct cons_pointer lisp_divide( struct return result; } - -/** - * @brief Function: return a real (approcimately) equal in value to the ratio - * which is the first argument. - * - * @param frame - * @param frame_pointer - * @param env - * @return struct cons_pointer a pointer to a real - */ -// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, -// struct cons_pointer env ) -struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env) { - struct cons_pointer result = NIL; - struct cons_pointer rat = frame->arg[0]; - - debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); - debug_print_object( rat, DEBUG_ARITH); - - if ( ratiop( rat)) { - result = make_real( c_ratio_to_ld( rat)); - } // TODO: else throw an exception? - - return result; -} \ No newline at end of file diff --git a/src/arith/peano.h b/src/arith/peano.h index 8b2908c..5e83f0c 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -75,7 +75,4 @@ struct cons_pointer lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env); - #endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 9c7c524..5608717 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,17 +11,15 @@ #include #include -#include "arith/integer.h" -#include "arith/peano.h" -#include "arith/ratio.h" -#include "arith/real.h" -#include "debug.h" -#include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" -#include "memory/stack.h" +#include "debug.h" #include "ops/equal.h" +#include "arith/integer.h" #include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" /** @@ -93,10 +91,11 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; - debug_print( L"\naadd_ratio_ratio: ", DEBUG_ARITH); - debug_print_object( arg1, DEBUG_ARITH); - debug_print( L" + ", DEBUG_ARITH); - debug_print_object( arg2, DEBUG_ARITH); + debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); @@ -112,7 +111,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; - debug_printf( DEBUG_ARITH, L"; lcm = %ld; m1 = %ld; m2 = %ld", lcm, + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { @@ -171,11 +170,6 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; - debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH); - debug_print_object( intarg, DEBUG_ARITH); - debug_print( L" + ", DEBUG_ARITH); - debug_print_object( ratarg, DEBUG_ARITH); - if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: not longer works struct cons_pointer one = acquire_integer( 1, NIL ), @@ -194,10 +188,6 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, NIL ) ) ), NIL ); } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - return result; } @@ -209,10 +199,6 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH); - debug_print_object( arg1, DEBUG_ARITH); - debug_print( L" / ", DEBUG_ARITH); - debug_print_object( arg2, DEBUG_ARITH); // TODO: this now has to work if `arg1` is an integer struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, @@ -221,10 +207,6 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, dec_ref( i ); - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - return result; } @@ -277,10 +259,6 @@ struct cons_pointer multiply_ratio_ratio( struct NIL ); } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - return result; } @@ -294,11 +272,6 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; - debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH); - debug_print_object( intarg, DEBUG_ARITH); - debug_print( L" * ", DEBUG_ARITH); - debug_print_object( ratarg, DEBUG_ARITH); - if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: no longer works; fix struct cons_pointer one = acquire_integer( 1, NIL ), @@ -313,10 +286,6 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, NIL ); } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - return result; } @@ -329,11 +298,6 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH); - debug_print_object( arg1, DEBUG_ARITH); - debug_print( L" * ", DEBUG_ARITH); - debug_print_object( arg2, DEBUG_ARITH); - struct cons_pointer i = negative( arg2 ), result = add_ratio_ratio( arg1, i ); @@ -397,35 +361,3 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { return result; } - -/** - * @brief convert a ratio to an equivalent long double. - * - * @param rat a pointer to a ratio. - * @return long double - */ -long double c_ratio_to_ld( struct cons_pointer rat) { - long double result = NAN; - - debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); - debug_print_object( rat, DEBUG_ARITH); - - if ( ratiop( rat)) { - struct cons_space_object * cell_a = & pointer2cell( rat); - struct cons_pointer dv = cell_a->payload.ratio.divisor; - struct cons_space_object * dv_cell = &pointer2cell( dv); - struct cons_pointer dd = cell_a->payload.ratio.dividend; - struct cons_space_object * dd_cell = &pointer2cell( dd); - - if ( nilp( dv_cell->payload.integer.more) && nilp( dd_cell->payload.integer.more)) { - result = ((long double) dd_cell->payload.integer.value) / ((long double) dv_cell->payload.integer.value);; - } else { - fwprintf( stderr, L"real conversion is not yet implemented for bignums rationals."); - } - } - - debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result ); - - return result; -} - diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 8d93f44..9068bfb 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -36,6 +36,4 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); -long double c_ratio_to_ld( struct cons_pointer rat); - #endif diff --git a/src/init.c b/src/init.c index 2d3d394..912ba45 100644 --- a/src/init.c +++ b/src/init.c @@ -20,7 +20,6 @@ /* libcurl, used for io */ #include -#include "arith/ratio.h" #include "version.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" @@ -348,7 +347,6 @@ int main( int argc, char *argv[] ) { bind_function( L"print", &lisp_print ); bind_function( L"put!", lisp_hashmap_put ); bind_function( L"put-all!", &lisp_hashmap_put_all ); - bind_function( L"ratio->real", &lisp_ratio_to_real ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/ops/equal.c b/src/ops/equal.c index 0b21060..39d80af 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -15,7 +15,6 @@ #include "arith/integer.h" #include "arith/peano.h" #include "arith/ratio.h" -#include "debug.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -49,198 +48,11 @@ bool end_of_string( struct cons_pointer string ) { pointer2cell( string ).payload.string.character == '\0'; } -/** - * @brief compare two long doubles and returns true if they are the same to - * within a tolerance of one part in a billion. - * - * @param a - * @param b - * @return true if `a` and `b` are equal to within one part in a billion. - * @return false otherwise. - */ -bool equal_ld_ld( long double a, long double b) { - long double fa = fabsl( a); - long double fb = fabsl( b); - /* difference of magnitudes */ - long double diff = fabsl( fa - fb); - /* average magnitude of the two */ - long double av = (fa > fb) ? ( fa - diff) : ( fb - diff); - /* amount of difference we will tolerate for equality */ - long double tolerance = av * 0.000000001; - - bool result = ( fabsl( a - b) < tolerance); - - debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp integer -- if it isn't an integer, things will break. - * @param b a lisp real -- if it isn't a real, things will break. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ){ - debug_print( L"\nequal_integer_real: ", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L" = ", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); - bool result = false; - struct cons_space_object * cell_a = &pointer2cell( a); - struct cons_space_object * cell_b = & pointer2cell( b); - - if (nilp( cell_a->payload.integer.more)) { - result = equal_ld_ld( (long double) cell_a->payload.integer.value, cell_b->payload.real.value); - } else { - fwprintf( stderr, L"\nequality is not yet implemented for bignums compared to reals."); - } - - debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp integer -- if it isn't an integer, things will break. - * @param b a lisp number. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal_integer_number: ", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L" = ", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); - bool result = false; - struct cons_space_object * cell_b = & pointer2cell( b); - - switch ( cell_b->tag.value) { - case INTEGERTV: - result = equal_integer_integer( a, b); - break; - case REALTV: - result = equal_integer_real( a, b); - break; - case RATIOTV: - result = false; - break; - } - - debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp real -- if it isn't an real, things will break. - * @param b a lisp number. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_real_number( struct cons_pointer a, struct cons_pointer b) { - debug_print( L"\nequal_real_number: ", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L" = ", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); - bool result = false; - struct cons_space_object * cell_b = & pointer2cell( b); - - switch ( cell_b->tag.value) { - case INTEGERTV: - result = equal_integer_real( b, a); - break; - case REALTV: { - struct cons_space_object * cell_a = & pointer2cell( a); - result = equal_ld_ld( cell_a->payload.real.value, cell_b->payload.real.value); - } - break; - case RATIOTV: - struct cons_space_object * cell_a = & pointer2cell( a); - result = equal_ld_ld( c_ratio_to_ld( b), cell_a->payload.real.value); - break; - } - - debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a number - * @param b a number - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) { - bool result = eq( a, b ); - - debug_print( L"\nequal_number_number: ", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L" = ", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); - - if ( !result ) { - struct cons_space_object * cell_a = & pointer2cell( a); - struct cons_space_object * cell_b = & pointer2cell( b); - - switch ( cell_a->tag.value) { - case INTEGERTV: - result = equal_integer_number( a, b); - break; - case REALTV: - result = equal_real_number( a, b); - break; - case RATIOTV: - switch( cell_b->tag.value) { - case INTEGERTV: - /* as all ratios are simplified by make_ratio, any - * ratio that would simplify to an integer is an - * integer, */ - result = false; - break; - case REALTV: - result = equal_real_number( b, a); - break; - case RATIOTV: - result = equal_ratio_ratio( a, b); - break; - /* can't throw an exception from here, but non-numbers - * shouldn't have been passed in anyway, so no default. */ - } - break; - /* can't throw an exception from here, but non-numbers - * shouldn't have been passed in anyway, so no default. */ - } - } - - debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n", result ); - - return result; -} - /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ bool equal( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal: ", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L" = ", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); - bool result = eq( a, b ); if ( !result && same_type( a, b ) ) { @@ -309,7 +121,11 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; } } else if ( numberp( a ) && numberp( b ) ) { - result = equal_number_number( a, b); + if ( integerp( a ) ) { + result = equal_integer_real( a, b ); + } else if ( integerp( b ) ) { + result = equal_integer_real( b, a ); + } } /* @@ -320,7 +136,5 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * I'll ignore them, too, for now. */ - debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result ); - return result; }