simon/post-scarcity
1
0
Fork 0
Code Issues 4 Pull requests Projects Releases Packages Wiki Activity Actions

Added a flag, simplify to the arg list of make_ratio, so that we can

Browse source 
create ratios which would otherwise somplify to integers, in order to
make ratio arithmetic easier.
This commit is contained in:
Simon Brooke 2026-02-15 23:47:28 +00:00
parent 169afc9eb4
commit 8629e33f92
11 changed files with 213 additions and 180 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile
View file

@ -30,6 +30,7 @@ $(TARGET): $(OBJS) Makefile
doc: $(SRCS) Makefile Doxyfile doc: $(SRCS) Makefile Doxyfile
doxygen doxygen
tar czvf target/doc.tgz doc
format: $(SRCS) $(HDRS) Makefile format: $(SRCS) $(HDRS) Makefile
ifeq ($(shell uname -s), Darwin) ifeq ($(shell uname -s), Darwin)

21
docs/state-of-play.md
View file

@ -22,6 +22,27 @@ fractions once bignums are working.
So we're down to eight unit tests failing: the memory leak, one unimplemented So we're down to eight unit tests failing: the memory leak, one unimplemented
feature, and the bignum problem. feature, and the bignum problem.
At the end of the day I decided to chew up some memory by doing a series of
moderately large computations, to see how much memory is being successfully
deallocated.
```lisp
:: (mapcar fact '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
(1 2 6 24 120 720 5,040 40,320 362,880 3,628,800 39,916,800 479,001,600
1,932,053,504 1,278,945,280 2,004,310,016 2,004,189,184 4,006,445,056
3,396,534,272 109,641,728 2,192,834,560)
::
Allocation summary: allocated 10136; deallocated 548; not deallocated 9588.
```
So, about 5%. This is still a major problem, and is making me doubt my reference
counting strategy. Must do better!
Note that the reason that the numbers become eratic past about two billion is
the bignum arithmetic bug.
## 20260214 ## 20260214
### Memory leaks ### Memory leaks

41
src/arith/peano.c
View file

@ -99,7 +99,7 @@ struct cons_pointer absolute( struct cons_pointer arg ) {
break; break;
case RATIOTV: case RATIOTV:
result = make_ratio( absolute( cell.payload.ratio.dividend ), result = make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor, false );
break; break;
case REALTV: case REALTV:
result = make_real( 0 - cell.payload.real.value ); result = make_real( 0 - cell.payload.real.value );
@ -504,7 +504,7 @@ struct cons_pointer negative( struct cons_pointer arg ) {
break; break;
case RATIOTV: case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ), result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor, false );
break; break;
case REALTV: case REALTV:
result = make_real( 0 - to_long_double( arg ) ); result = make_real( 0 - to_long_double( arg ) );
@ -566,7 +566,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case RATIOTV:{ case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1, struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1, make_integer( 1,
NIL ) ); NIL ), false );
inc_ref( tmp ); inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 ); result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp ); dec_ref( tmp );
@ -592,7 +592,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2, struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1, make_integer( 1,
NIL ) ); NIL ), false );
inc_ref( tmp ); inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp ); result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp ); dec_ref( tmp );
@ -670,21 +670,15 @@ struct cons_pointer lisp_divide( struct
result = frame->arg[1]; result = frame->arg[1];
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer unsimplified = result =
make_ratio( frame->arg[0], make_ratio( frame->arg[0],
frame->arg[1] ); frame->arg[1], true);
/* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} }
break; break;
case RATIOTV:{ case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[0], one ); make_ratio( frame->arg[0], one, false );
inc_ref( ratio ); inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] ); result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
@ -709,11 +703,9 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer one = make_integer( 1, NIL );
inc_ref( one );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[1], one ); make_ratio( frame->arg[1], one, false);
inc_ref( ratio ); result = divide_ratio_ratio( frame->arg[0], ratio );
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref( one ); dec_ref( one );
} }
@ -760,17 +752,18 @@ struct cons_pointer lisp_divide( struct
*/ */
// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, // struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
// struct cons_pointer env ) // struct cons_pointer env )
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer env) { struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer rat = frame->arg[0]; struct cons_pointer rat = frame->arg[0];
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH); debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat)) { if ( ratiop( rat ) ) {
result = make_real( c_ratio_to_ld( rat)); result = make_real( c_ratio_to_ld( rat ) );
} // TODO: else throw an exception? } // TODO: else throw an exception?
return result; return result;
} }

5
src/arith/peano.h
View file

@ -75,7 +75,8 @@ struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif /* PEANO_H */ #endif /* PEANO_H */

132
src/arith/ratio.c
View file

@ -64,14 +64,15 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
result = acquire_integer( (int64_t)(ddrv / gcd), NIL ); result =
acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL );
} else { } else {
debug_printf( DEBUG_ARITH, debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n", L"simplify_ratio: %ld/%ld => %ld/%ld\n",
ddrv, drrv, ddrv / gcd, drrv / gcd ); ddrv, drrv, ddrv / gcd, drrv / gcd );
result = result =
make_ratio( acquire_integer( ddrv / gcd, NIL ), make_ratio( acquire_integer( ddrv / gcd, NIL ),
acquire_integer( drrv / gcd, NIL ) ); acquire_integer( drrv / gcd, NIL ), false);
} }
} }
} }
@ -93,25 +94,26 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer r; struct cons_pointer r;
debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH); debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH); debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH); debug_print( L" + ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH); debug_print_object( arg2, DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object * cell1 = &pointer2cell( arg1 ); struct cons_space_object *cell1 = &pointer2cell( arg1 );
struct cons_space_object * cell2 = &pointer2cell( arg2 ); struct cons_space_object *cell2 = &pointer2cell( arg2 );
struct cons_pointer divisor = multiply_integers( cell1->payload.ratio.divisor, cell2->payload.ratio.divisor ); struct cons_pointer divisor =
struct cons_pointer dividend = add_integers( multiply_integers( cell1->payload.ratio.divisor,
multiply_integers( cell1->payload.ratio.dividend, cell2->payload.ratio.divisor );
cell2->payload.ratio.divisor), struct cons_pointer dividend =
multiply_integers( cell2->payload.ratio.dividend, add_integers( multiply_integers( cell1->payload.ratio.dividend,
cell1->payload.ratio.divisor)); cell2->payload.ratio.divisor ),
r = make_ratio( dividend, divisor ); multiply_integers( cell2->payload.ratio.dividend,
cell1->payload.ratio.divisor ) );
r = make_ratio( dividend, divisor, true );
} else { } else {
r = r = throw_exception( make_cons( c_string_to_lisp_string
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
@ -136,15 +138,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH); debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH); debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH); debug_print( L" + ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH); debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: not longer works
struct cons_pointer one = acquire_integer( 1, NIL ), struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one ); ratio = make_ratio( intarg, one, false );
result = add_ratio_ratio( ratio, ratarg ); result = add_ratio_ratio( ratio, ratarg );
@ -174,14 +175,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
*/ */
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH); debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH); debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" / ", DEBUG_ARITH); debug_print( L" / ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH); debug_print_object( arg2, DEBUG_ARITH );
// TODO: this now has to work if `arg1` is an integer // TODO: this now has to work if `arg1` is an integer
struct cons_pointer i = struct cons_pointer i =
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
pointer2cell( arg2 ).payload.ratio.dividend ), result = pointer2cell( arg2 ).payload.ratio.dividend, false ), result =
multiply_ratio_ratio( arg1, i ); multiply_ratio_ratio( arg1, i );
dec_ref( i ); dec_ref( i );
@ -226,15 +227,10 @@ struct cons_pointer multiply_ratio_ratio( struct
struct cons_pointer dividend = acquire_integer( ddrv, NIL ); struct cons_pointer dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL ); struct cons_pointer divisor = acquire_integer( drrv, NIL );
struct cons_pointer unsimplified = make_ratio( dividend, divisor ); result = make_ratio( dividend, divisor, true );
result = simplify_ratio( unsimplified );
release_integer( dividend ); release_integer( dividend );
release_integer( divisor ); release_integer( divisor );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
@ -259,15 +255,14 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH); debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH); debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH); debug_print( L" * ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH); debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: no longer works; fix
struct cons_pointer one = acquire_integer( 1, NIL ), struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one ); ratio = make_ratio( intarg, one, false );
result = multiply_ratio_ratio( ratio, ratarg ); result = multiply_ratio_ratio( ratio, ratarg );
release_integer( one ); release_integer( one );
@ -294,10 +289,10 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
*/ */
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH); debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH); debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH); debug_print( L" * ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH); debug_print_object( arg2, DEBUG_ARITH );
struct cons_pointer i = negative( arg2 ), struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i ); result = add_ratio_ratio( arg1, i );
@ -315,7 +310,14 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
* @exception if either `dividend` or `divisor` is not an integer. * @exception if either `dividend` or `divisor` is not an integer.
*/ */
struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor ) { struct cons_pointer divisor,
bool simplify ) {
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC);
debug_print_object( dividend, DEBUG_ALLOC);
debug_print( L"; divisor = ", DEBUG_ALLOC);
debug_print_object( divisor, DEBUG_ALLOC);
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify);
struct cons_pointer result; struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) { if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend ); inc_ref( dividend );
@ -325,9 +327,13 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
cell->payload.ratio.dividend = dividend; cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor; cell->payload.ratio.divisor = divisor;
result = simplify_ratio( unsimplified ); if ( simplify) {
if ( !eq( result, unsimplified ) ) { result = simplify_ratio( unsimplified );
dec_ref( unsimplified ); if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
}
} else {
result = unsimplified;
} }
} else { } else {
result = result =
@ -335,8 +341,9 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
( L"Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
NIL ); NIL );
} }
// debug_print( L"make_ratio returning:\n", DEBUG_ARITH); debug_print( L" => ", DEBUG_ALLOC);
debug_dump_object( result, DEBUG_ARITH ); debug_print_object( result, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC);
return result; return result;
} }
@ -369,23 +376,27 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
* @param rat a pointer to a ratio. * @param rat a pointer to a ratio.
* @return long double * @return long double
*/ */
long double c_ratio_to_ld( struct cons_pointer rat) { long double c_ratio_to_ld( struct cons_pointer rat ) {
long double result = NAN; long double result = NAN;
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH); debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat)) { if ( ratiop( rat ) ) {
struct cons_space_object * cell_a = & pointer2cell( rat); struct cons_space_object *cell_a = &pointer2cell( rat );
struct cons_pointer dv = cell_a->payload.ratio.divisor; struct cons_pointer dv = cell_a->payload.ratio.divisor;
struct cons_space_object * dv_cell = &pointer2cell( dv); struct cons_space_object *dv_cell = &pointer2cell( dv );
struct cons_pointer dd = cell_a->payload.ratio.dividend; struct cons_pointer dd = cell_a->payload.ratio.dividend;
struct cons_space_object * dd_cell = &pointer2cell( dd); struct cons_space_object *dd_cell = &pointer2cell( dd );
if ( nilp( dv_cell->payload.integer.more) && nilp( dd_cell->payload.integer.more)) { if ( nilp( dv_cell->payload.integer.more )
result = ((long double) dd_cell->payload.integer.value) / ((long double) dv_cell->payload.integer.value);; && nilp( dd_cell->payload.integer.more ) ) {
result =
( ( long double ) dd_cell->payload.integer.value ) /
( ( long double ) dv_cell->payload.integer.value );;
} else { } else {
fwprintf( stderr, L"real conversion is not yet implemented for bignums rationals."); fwprintf( stderr,
L"real conversion is not yet implemented for bignums rationals." );
} }
} }
@ -393,4 +404,3 @@ long double c_ratio_to_ld( struct cons_pointer rat) {
return result; return result;
} }

5
src/arith/ratio.h
View file

@ -32,10 +32,11 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor ); struct cons_pointer divisor,
bool simplify );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
long double c_ratio_to_ld( struct cons_pointer rat); long double c_ratio_to_ld( struct cons_pointer rat );
#endif #endif

4
src/io/io.c
View file

@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload. ( pointer2cell( frame->arg[0] ).payload.stream.
stream.stream ), NIL ); stream ), NIL );
} }
return result; return result;

6
src/io/read.c
View file

@ -90,7 +90,7 @@ struct cons_pointer read_path( URL_FILE *input, wint_t initial,
switch ( initial ) { switch ( initial ) {
case '/': case '/':
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL); prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL );
break; break;
case '$': case '$':
case LSESSION: case LSESSION:
@ -370,7 +370,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
( to_long_double ( to_long_double
( base ), ( base ),
places_of_decimals ), places_of_decimals ),
NIL ) ); NIL ), true);
inc_ref( div ); inc_ref( div );
result = make_real( to_long_double( div ) ); result = make_real( to_long_double( div ) );
@ -378,7 +378,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
dec_ref( div ); dec_ref( div );
} else if ( integerp( dividend ) ) { } else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
result = make_ratio( dividend, result ); result = make_ratio( dividend, result, true );
} }
if ( neg ) { if ( neg ) {

8
src/memory/dump.c
View file

@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
case RATIOTV: case RATIOTV:
url_fwprintf( output, url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ). pointer2cell( cell.payload.ratio.dividend ).payload.
payload.integer.value, integer.value,
pointer2cell( cell.payload.ratio.divisor ). pointer2cell( cell.payload.ratio.divisor ).payload.
payload.integer.value, cell.count ); integer.value, cell.count );
break; break;
case READTV: case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output ); url_fputws( L"\t\tInput stream; metadata: ", output );

131
src/ops/equal.c
View file

@ -58,17 +58,17 @@ bool end_of_string( struct cons_pointer string ) {
* @return true if `a` and `b` are equal to within one part in a billion. * @return true if `a` and `b` are equal to within one part in a billion.
* @return false otherwise. * @return false otherwise.
*/ */
bool equal_ld_ld( long double a, long double b) { bool equal_ld_ld( long double a, long double b ) {
long double fa = fabsl( a); long double fa = fabsl( a );
long double fb = fabsl( b); long double fb = fabsl( b );
/* difference of magnitudes */ /* difference of magnitudes */
long double diff = fabsl( fa - fb); long double diff = fabsl( fa - fb );
/* average magnitude of the two */ /* average magnitude of the two */
long double av = (fa > fb) ? ( fa - diff) : ( fb - diff); long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
/* amount of difference we will tolerate for equality */ /* amount of difference we will tolerate for equality */
long double tolerance = av * 0.000000001; long double tolerance = av * 0.000000001;
bool result = ( fabsl( a - b) < tolerance); bool result = ( fabsl( a - b ) < tolerance );
debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result ); debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result );
@ -84,22 +84,26 @@ bool equal_ld_ld( long double a, long double b) {
* @return true if the two numbers have equal value. * @return true if the two numbers have equal value.
* @return false if they don't. * @return false if they don't.
*/ */
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ){ bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_real: ", DEBUG_ARITH); debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH); debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH); debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH); debug_print_object( b, DEBUG_ARITH );
bool result = false; bool result = false;
struct cons_space_object * cell_a = &pointer2cell( a); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object * cell_b = & pointer2cell( b); struct cons_space_object *cell_b = &pointer2cell( b );
if (nilp( cell_a->payload.integer.more)) { if ( nilp( cell_a->payload.integer.more ) ) {
result = equal_ld_ld( (long double) cell_a->payload.integer.value, cell_b->payload.real.value); result =
equal_ld_ld( ( long double ) cell_a->payload.integer.value,
cell_b->payload.real.value );
} else { } else {
fwprintf( stderr, L"\nequality is not yet implemented for bignums compared to reals."); 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 ); debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
result );
return result; return result;
} }
@ -114,26 +118,27 @@ bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ){
* @return false if they don't. * @return false if they don't.
*/ */
bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) { bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_number: ", DEBUG_ARITH); debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH); debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH); debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH); debug_print_object( b, DEBUG_ARITH );
bool result = false; bool result = false;
struct cons_space_object * cell_b = & pointer2cell( b); struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value) { switch ( cell_b->tag.value ) {
case INTEGERTV: case INTEGERTV:
result = equal_integer_integer( a, b); result = equal_integer_integer( a, b );
break; break;
case REALTV: case REALTV:
result = equal_integer_real( a, b); result = equal_integer_real( a, b );
break; break;
case RATIOTV: case RATIOTV:
result = false; result = false;
break; break;
} }
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n", result ); debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
result );
return result; return result;
} }
@ -147,30 +152,33 @@ bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
* @return true if the two numbers have equal value. * @return true if the two numbers have equal value.
* @return false if they don't. * @return false if they don't.
*/ */
bool equal_real_number( struct cons_pointer a, struct cons_pointer b) { bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_real_number: ", DEBUG_ARITH); debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH); debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH); debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH); debug_print_object( b, DEBUG_ARITH );
bool result = false; bool result = false;
struct cons_space_object * cell_b = & pointer2cell( b); struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value) { switch ( cell_b->tag.value ) {
case INTEGERTV: case INTEGERTV:
result = equal_integer_real( b, a); result = equal_integer_real( b, a );
break; break;
case REALTV: { case REALTV:{
struct cons_space_object * cell_a = & pointer2cell( a); struct cons_space_object *cell_a = &pointer2cell( a );
result = equal_ld_ld( cell_a->payload.real.value, cell_b->payload.real.value); result =
equal_ld_ld( cell_a->payload.real.value,
cell_b->payload.real.value );
} }
break; break;
case RATIOTV: case RATIOTV:
struct cons_space_object * cell_a = & pointer2cell( a); struct cons_space_object *cell_a = &pointer2cell( a );
result = equal_ld_ld( c_ratio_to_ld( b), cell_a->payload.real.value); result =
equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
break; break;
} }
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result ); debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
return result; return result;
} }
@ -187,24 +195,24 @@ bool equal_real_number( struct cons_pointer a, struct cons_pointer b) {
bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) { bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b ); bool result = eq( a, b );
debug_print( L"\nequal_number_number: ", DEBUG_ARITH); debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH); debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH); debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH); debug_print_object( b, DEBUG_ARITH );
if ( !result ) { if ( !result ) {
struct cons_space_object * cell_a = & pointer2cell( a); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object * cell_b = & pointer2cell( b); struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value) { switch ( cell_a->tag.value ) {
case INTEGERTV: case INTEGERTV:
result = equal_integer_number( a, b); result = equal_integer_number( a, b );
break; break;
case REALTV: case REALTV:
result = equal_real_number( a, b); result = equal_real_number( a, b );
break; break;
case RATIOTV: case RATIOTV:
switch( cell_b->tag.value) { switch ( cell_b->tag.value ) {
case INTEGERTV: case INTEGERTV:
/* as all ratios are simplified by make_ratio, any /* as all ratios are simplified by make_ratio, any
* ratio that would simplify to an integer is an * ratio that would simplify to an integer is an
@ -212,13 +220,13 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
result = false; result = false;
break; break;
case REALTV: case REALTV:
result = equal_real_number( b, a); result = equal_real_number( b, a );
break; break;
case RATIOTV: case RATIOTV:
result = equal_ratio_ratio( a, b); result = equal_ratio_ratio( a, b );
break; break;
/* can't throw an exception from here, but non-numbers /* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */ * shouldn't have been passed in anyway, so no default. */
} }
break; break;
/* can't throw an exception from here, but non-numbers /* can't throw an exception from here, but non-numbers
@ -226,7 +234,8 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
} }
} }
debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n", result ); debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
result );
return result; return result;
} }
@ -236,10 +245,10 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
* identical structure, else false. * identical structure, else false.
*/ */
bool equal( struct cons_pointer a, struct cons_pointer b ) { bool equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal: ", DEBUG_ARITH); debug_print( L"\nequal: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH); debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH); debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH); debug_print_object( b, DEBUG_ARITH );
bool result = eq( a, b ); bool result = eq( a, b );
@ -309,7 +318,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
break; break;
} }
} else if ( numberp( a ) && numberp( b ) ) { } else if ( numberp( a ) && numberp( b ) ) {
result = equal_number_number( a, b); result = equal_number_number( a, b );
} }
/* /*

19
src/ops/lispops.c
View file

@ -446,10 +446,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer; result = next_pointer;
} else { } else {
result = result =
( *fn_cell.payload. ( *fn_cell.payload.special.
special.executable ) ( get_stack_frame executable ) ( get_stack_frame( next_pointer ),
( next_pointer ), next_pointer, env );
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
@ -1246,8 +1245,7 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0]; struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception( message, return exceptionp( message ) ? message : throw_exception( message,
frame-> frame->previous );
previous );
} }
/** /**
@ -1430,14 +1428,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) { if ( nilp( c_cdr( l1 ) ) ) {
return return
make_string_like_thing( ( pointer2cell( l1 ). make_string_like_thing( ( pointer2cell( l1 ).payload.
payload.string.character ), string.character ), l2,
l2,
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} else { } else {
return return
make_string_like_thing( ( pointer2cell( l1 ). make_string_like_thing( ( pointer2cell( l1 ).payload.
payload.string.character ), string.character ),
c_append( c_cdr( l1 ), l2 ), c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} }