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
doxygen
tar czvf target/doc.tgz doc
format: $(SRCS) $(HDRS) Makefile
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
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
### Memory leaks

43
src/arith/peano.c
View file

@ -99,7 +99,7 @@ struct cons_pointer absolute( struct cons_pointer arg ) {
break;
case RATIOTV:
result = make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor );
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - cell.payload.real.value );
@ -504,7 +504,7 @@ struct cons_pointer negative( struct cons_pointer arg ) {
break;
case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor );
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
@ -566,7 +566,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1,
NIL ) );
NIL ), false );
inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
@ -592,7 +592,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1,
NIL ) );
NIL ), false );
inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
@ -670,21 +670,15 @@ struct cons_pointer lisp_divide( struct
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
result =
make_ratio( frame->arg[0],
frame->arg[1] );
/* 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 );
}
frame->arg[1], true);
}
break;
case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame->arg[0], one );
make_ratio( frame->arg[0], one, false );
inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio );
@ -709,11 +703,9 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL );
inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame->arg[1], one );
inc_ref( ratio );
result = divide_ratio_ratio( frame->arg[0], ratio );
make_ratio( frame->arg[1], one, false);
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio );
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 env )
struct cons_pointer lisp_ratio_to_real( 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);
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?
if ( ratiop( rat ) ) {
result = make_real( c_ratio_to_ld( rat ) );
} // TODO: else throw an exception?
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,
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 lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif /* PEANO_H */

140
src/arith/ratio.c
View file

@ -64,14 +64,15 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
result = acquire_integer( (int64_t)(ddrv / gcd), NIL );
result =
acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL );
} else {
debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n",
ddrv, drrv, ddrv / gcd, drrv / gcd );
result =
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 r;
debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH);
debug_print_object( arg1, DEBUG_ARITH);
debug_print( L" + ", DEBUG_ARITH);
debug_print_object( arg2, DEBUG_ARITH);
debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object * cell1 = &pointer2cell( arg1 );
struct cons_space_object * cell2 = &pointer2cell( arg2 );
struct cons_pointer divisor = multiply_integers( cell1->payload.ratio.divisor, cell2->payload.ratio.divisor );
struct cons_pointer dividend = add_integers(
multiply_integers( cell1->payload.ratio.dividend,
cell2->payload.ratio.divisor),
multiply_integers( cell2->payload.ratio.dividend,
cell1->payload.ratio.divisor));
r = make_ratio( dividend, divisor );
struct cons_space_object *cell1 = &pointer2cell( arg1 );
struct cons_space_object *cell2 = &pointer2cell( arg2 );
struct cons_pointer divisor =
multiply_integers( cell1->payload.ratio.divisor,
cell2->payload.ratio.divisor );
struct cons_pointer dividend =
add_integers( multiply_integers( cell1->payload.ratio.dividend,
cell2->payload.ratio.divisor ),
multiply_integers( cell2->payload.ratio.dividend,
cell1->payload.ratio.divisor ) );
r = make_ratio( dividend, divisor, true );
} else {
r =
throw_exception( make_cons( c_string_to_lisp_string
r = throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
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 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);
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 ),
ratio = make_ratio( intarg, one );
ratio = make_ratio( intarg, one, false );
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 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);
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,
pointer2cell( arg2 ).payload.ratio.dividend ), result =
pointer2cell( arg2 ).payload.ratio.dividend, false ), result =
multiply_ratio_ratio( arg1, 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 divisor = acquire_integer( drrv, NIL );
struct cons_pointer unsimplified = make_ratio( dividend, divisor );
result = simplify_ratio( unsimplified );
result = make_ratio( dividend, divisor, true );
release_integer( dividend );
release_integer( divisor );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else {
result =
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 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);
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 ),
ratio = make_ratio( intarg, one );
ratio = make_ratio( intarg, one, false );
result = multiply_ratio_ratio( ratio, ratarg );
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 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);
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 );
@ -315,7 +310,14 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
* @exception if either `dividend` or `divisor` is not an integer.
*/
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;
if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend );
@ -325,9 +327,13 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
if ( simplify) {
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
}
} else {
result = unsimplified;
}
} else {
result =
@ -335,8 +341,9 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
( L"Dividend and divisor of a ratio must be integers" ),
NIL );
}
// debug_print( L"make_ratio returning:\n", DEBUG_ARITH);
debug_dump_object( result, DEBUG_ARITH );
debug_print( L" => ", DEBUG_ALLOC);
debug_print_object( result, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC);
return result;
}
@ -369,28 +376,31 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
* @param rat a pointer to a ratio.
* @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;
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH);
debug_print_object( rat, DEBUG_ARITH);
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);
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_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);;
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.");
}
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;
}

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 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 );
long double c_ratio_to_ld( struct cons_pointer rat);
long double c_ratio_to_ld( struct cons_pointer rat );
#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] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
}
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 ) {
case '/':
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL);
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL );
break;
case '$':
case LSESSION:
@ -370,7 +370,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
( to_long_double
( base ),
places_of_decimals ),
NIL ) );
NIL ), true);
inc_ref( div );
result = make_real( to_long_double( div ) );
@ -378,7 +378,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
dec_ref( div );
} else if ( integerp( dividend ) ) {
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 ) {

8
src/memory/dump.c
View file

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

141
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 false otherwise.
*/
bool equal_ld_ld( long double a, long double b) {
long double fa = fabsl( a);
long double fb = fabsl( b);
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);
long double diff = fabsl( fa - fb );
/* 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 */
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 );
@ -84,22 +84,26 @@ bool equal_ld_ld( long double a, long double b) {
* @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 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);
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);
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.");
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;
}
@ -114,26 +118,27 @@ bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ){
* @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);
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);
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value) {
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_integer( a, b);
result = equal_integer_integer( a, b );
break;
case REALTV:
result = equal_integer_real( a, b);
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 );
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
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 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 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);
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value) {
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_real( b, a);
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);
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);
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 );
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", 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 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);
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);
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);
switch ( cell_a->tag.value ) {
case INTEGERTV:
result = equal_integer_number( a, b );
break;
case REALTV:
result = equal_real_number( a, b);
result = equal_real_number( a, b );
break;
case RATIOTV:
switch( cell_b->tag.value) {
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
@ -212,13 +220,13 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
result = false;
break;
case REALTV:
result = equal_real_number( b, a);
result = equal_real_number( b, a );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b);
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. */
/* 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
@ -226,20 +234,21 @@ 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;
}
/**
* 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);
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 );
@ -309,7 +318,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
break;
}
} 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;
} else {
result =
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, 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 message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception( message,
frame->
previous );
frame->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 ( nilp( c_cdr( l1 ) ) ) {
return
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
l2,
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ), l2,
pointer2cell( l1 ).tag.value );
} else {
return
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ),
c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value );
}