Ratio multiplication and subtraction
This commit is contained in:
parent
d725097f89
commit
7e98207f7e
|
@ -127,6 +127,9 @@ void dump_pages( FILE * output ) {
|
|||
void free_cell( struct cons_pointer pointer ) {
|
||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||
|
||||
fwprintf( stderr, L"Freeing cell " );
|
||||
dump_object( stderr, pointer );
|
||||
|
||||
switch ( cell->tag.value ) {
|
||||
/* for all the types of cons-space object which point to other
|
||||
* cons-space objects, cascade the decrement. */
|
||||
|
@ -160,20 +163,18 @@ void free_cell( struct cons_pointer pointer ) {
|
|||
|
||||
if ( !check_tag( pointer, FREETAG ) ) {
|
||||
if ( cell->count == 0 ) {
|
||||
fwprintf( stderr, L"Freeing cell " );
|
||||
dump_object( stderr, pointer );
|
||||
strncpy( &cell->tag.bytes[0], FREETAG, 4 );
|
||||
cell->payload.free.car = NIL;
|
||||
cell->payload.free.cdr = freelist;
|
||||
freelist = pointer;
|
||||
} else {
|
||||
fwprintf( stderr,
|
||||
L"Attempt to free cell with %d dangling references at page %d, offset %d\n",
|
||||
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
|
||||
cell->count, pointer.page, pointer.offset );
|
||||
}
|
||||
} else {
|
||||
fwprintf( stderr,
|
||||
L"Attempt to free cell which is already FREE at page %d, offset %d\n",
|
||||
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
|
||||
pointer.page, pointer.offset );
|
||||
}
|
||||
}
|
||||
|
|
|
@ -133,6 +133,14 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
|
|||
fwprintf( output, L";\n\t\t\tbody: " );
|
||||
print( output, cell.payload.lambda.body );
|
||||
break;
|
||||
case RATIOTV:
|
||||
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 );
|
||||
break;
|
||||
case READTV:
|
||||
fwprintf( output, L"\t\tInput stream\n" );
|
||||
case REALTV:
|
||||
|
|
411
src/peano.c
411
src/peano.c
|
@ -26,7 +26,7 @@
|
|||
#include "stack.h"
|
||||
|
||||
long double to_long_double( struct cons_pointer arg );
|
||||
long int to_long_int( struct stack_frame *frame, struct cons_pointer arg );
|
||||
long int to_long_int( struct cons_pointer arg );
|
||||
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
|
||||
struct cons_pointer arg2 );
|
||||
|
||||
|
@ -96,7 +96,7 @@ long double to_long_double( struct cons_pointer arg ) {
|
|||
* if a ratio may legally have zero as a divisor, or something which is
|
||||
* not a number (or is a big number) is passed in.
|
||||
*/
|
||||
long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ) {
|
||||
long int to_long_int( struct cons_pointer arg ) {
|
||||
long int result = 0;
|
||||
struct cons_space_object cell = pointer2cell( arg );
|
||||
switch ( cell.tag.value ) {
|
||||
|
@ -128,6 +128,28 @@ long int least_common_multiple( long int m, long int n ) {
|
|||
return m / greatest_common_divisor( m, n ) * n;
|
||||
}
|
||||
|
||||
struct cons_pointer simplify_ratio( struct stack_frame *frame,
|
||||
struct cons_pointer arg ) {
|
||||
struct cons_pointer result = arg;
|
||||
long int ddrv =
|
||||
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
|
||||
payload.integer.value, drrv =
|
||||
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
|
||||
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
|
||||
|
||||
if ( gcd > 1 ) {
|
||||
if ( drrv / gcd == 1 ) {
|
||||
result = make_integer( ddrv / gcd );
|
||||
} else {
|
||||
result =
|
||||
make_ratio( frame, make_integer( ddrv / gcd ),
|
||||
make_integer( drrv / gcd ) );
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* return a cons_pointer indicating a number which is the sum of
|
||||
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
|
||||
|
@ -141,7 +163,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
|
|||
fputws( L"; arg2 = ", stderr );
|
||||
print( stderr, arg2 );
|
||||
|
||||
struct cons_pointer result;
|
||||
struct cons_pointer r1, result;
|
||||
struct cons_space_object cell1 = pointer2cell( arg1 );
|
||||
struct cons_space_object cell2 = pointer2cell( arg2 );
|
||||
long int dd1v =
|
||||
|
@ -158,29 +180,11 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
|
|||
fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
|
||||
|
||||
if ( dr1v == dr2v ) {
|
||||
result =
|
||||
make_ratio( frame,
|
||||
r1 = make_ratio( frame,
|
||||
make_integer( dd1v + dd2v ),
|
||||
cell1.payload.ratio.divisor );
|
||||
|
||||
long int ddrv =
|
||||
pointer2cell( pointer2cell( result ).payload.ratio.
|
||||
dividend ).payload.integer.value, drrv =
|
||||
pointer2cell( pointer2cell( result ).payload.ratio.
|
||||
divisor ).payload.integer.value, gcd =
|
||||
greatest_common_divisor( ddrv, drrv );
|
||||
|
||||
if ( gcd > 1 ) {
|
||||
if ( drrv / gcd == 1 ) {
|
||||
result = make_integer( ddrv / gcd );
|
||||
} else {
|
||||
result =
|
||||
make_ratio( frame, make_integer( ddrv / gcd ),
|
||||
make_integer( drrv / gcd ) );
|
||||
}
|
||||
}
|
||||
} else {
|
||||
result = add_ratio_ratio( frame,
|
||||
r1 = add_ratio_ratio( frame,
|
||||
make_ratio( frame,
|
||||
make_integer( dd1v * m1 ),
|
||||
make_integer( dr1v * m1 ) ),
|
||||
|
@ -189,6 +193,11 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
|
|||
make_integer( dr2v * m2 ) ) );
|
||||
}
|
||||
|
||||
result = simplify_ratio( frame, r1 );
|
||||
if ( !eq( r1, result ) ) {
|
||||
dec_ref( r1 );
|
||||
}
|
||||
|
||||
fputws( L" => ", stderr );
|
||||
print( stderr, result );
|
||||
fputws( L"\n", stderr );
|
||||
|
@ -257,6 +266,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
|
|||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot add: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case RATIOTV:
|
||||
|
@ -275,6 +285,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
|
|||
make_real( to_long_double( arg1 ) +
|
||||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot add: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case REALTV:
|
||||
|
@ -292,7 +307,6 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
|
|||
print( stderr, arg2 );
|
||||
fputws( L"\n", stderr );
|
||||
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
@ -306,56 +320,173 @@ struct cons_pointer lisp_add( struct stack_frame
|
|||
*frame, struct
|
||||
cons_pointer env ) {
|
||||
struct cons_pointer result = make_integer( 0 );
|
||||
struct cons_pointer tmp;
|
||||
|
||||
for ( int i = 0;
|
||||
i < args_in_frame &&
|
||||
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
|
||||
tmp = result;
|
||||
result = add_2( frame, result, frame->arg[i] );
|
||||
if ( !eq( tmp, result ) ) {
|
||||
dec_ref( tmp );
|
||||
}
|
||||
}
|
||||
|
||||
struct cons_pointer more = frame->more;
|
||||
while ( consp( more ) && !exceptionp( result ) ) {
|
||||
tmp = result;
|
||||
result = add_2( frame, result, c_car( more ) );
|
||||
if ( !eq( tmp, result ) ) {
|
||||
dec_ref( tmp );
|
||||
}
|
||||
|
||||
more = c_cdr( more );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* Internal guts of multiply. Dark and mysterious.
|
||||
*/
|
||||
struct cons_pointer multiply_accumulate( struct
|
||||
cons_pointer arg, struct
|
||||
struct cons_pointer multiply_ratio_ratio( struct
|
||||
stack_frame
|
||||
*frame, long
|
||||
int
|
||||
*i_accumulator, long
|
||||
double
|
||||
*d_accumulator, int
|
||||
*is_int ) {
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_space_object cell = pointer2cell( arg );
|
||||
switch ( cell.tag.value ) {
|
||||
case INTEGERTV:
|
||||
( *i_accumulator ) *= cell.payload.integer.value;
|
||||
( *d_accumulator ) *= numeric_value( arg );
|
||||
break;
|
||||
case REALTV:
|
||||
( *d_accumulator ) *= cell.payload.real.value;
|
||||
( *is_int ) &= false;
|
||||
break;
|
||||
case EXCEPTIONTV:
|
||||
result = arg;
|
||||
break;
|
||||
default:
|
||||
result =
|
||||
lisp_throw
|
||||
( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ), frame );
|
||||
*frame, struct
|
||||
cons_pointer arg1, struct
|
||||
cons_pointer arg2 ) {
|
||||
fputws( L"multiply_ratio_ratio( arg1 = ", stderr );
|
||||
print( stderr, arg1 );
|
||||
fputws( L"; arg2 = ", stderr );
|
||||
print( stderr, arg2 );
|
||||
|
||||
struct cons_pointer result;
|
||||
struct cons_space_object cell1 = pointer2cell( arg1 );
|
||||
struct cons_space_object cell2 = pointer2cell( arg2 );
|
||||
long int dd1v =
|
||||
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
|
||||
dd2v =
|
||||
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
|
||||
dr1v =
|
||||
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
|
||||
dr2v =
|
||||
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
|
||||
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
|
||||
|
||||
struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ),
|
||||
make_integer( drrv ) );
|
||||
result = simplify_ratio( frame, unsimplified );
|
||||
|
||||
if ( !eq( unsimplified, result ) ) {
|
||||
dec_ref( unsimplified );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* return a cons_pointer indicating a number which is the sum of
|
||||
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
|
||||
* this is going to break horribly.
|
||||
*/
|
||||
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame,
|
||||
struct cons_pointer intarg,
|
||||
struct cons_pointer ratarg ) {
|
||||
return multiply_ratio_ratio( frame,
|
||||
make_ratio( frame, intarg,
|
||||
make_integer( 1 ) ), ratarg );
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* return a cons_pointer indicating a number which is the product of
|
||||
* the numbers indicated by `arg1` and `arg2`.
|
||||
*/
|
||||
struct cons_pointer multiply_2( struct stack_frame *frame,
|
||||
struct cons_pointer arg1,
|
||||
struct cons_pointer arg2 ) {
|
||||
struct cons_pointer result;
|
||||
struct cons_space_object cell1 = pointer2cell( arg1 );
|
||||
struct cons_space_object cell2 = pointer2cell( arg2 );
|
||||
|
||||
fputws( L"multiply_2( arg1 = ", stderr );
|
||||
print( stderr, arg1 );
|
||||
fputws( L"; arg2 = ", stderr );
|
||||
print( stderr, arg2 );
|
||||
|
||||
if ( zerop( arg1 ) ) {
|
||||
result = arg2;
|
||||
} else if ( zerop( arg2 ) ) {
|
||||
result = arg1;
|
||||
} else {
|
||||
|
||||
switch ( cell1.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = arg1;
|
||||
break;
|
||||
case INTEGERTV:
|
||||
switch ( cell2.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = arg2;
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result = make_integer( cell1.payload.integer.value *
|
||||
cell2.payload.integer.value );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = multiply_integer_ratio( frame, arg1, arg2 );
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( to_long_double( arg1 ) *
|
||||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case RATIOTV:
|
||||
switch ( cell2.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = arg2;
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result = multiply_integer_ratio( frame, arg2, arg1 );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = multiply_ratio_ratio( frame, arg1, arg2 );
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( to_long_double( arg1 ) *
|
||||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ),
|
||||
frame );
|
||||
}
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( to_long_double( arg1 ) *
|
||||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
fputws( L"}; => ", stderr );
|
||||
print( stderr, arg2 );
|
||||
fputws( L"\n", stderr );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* Multiply an indefinite number of numbers together
|
||||
* @param env the evaluation environment - ignored;
|
||||
|
@ -366,40 +497,79 @@ struct cons_pointer lisp_multiply( struct
|
|||
stack_frame
|
||||
*frame, struct
|
||||
cons_pointer env ) {
|
||||
struct cons_pointer result = NIL;
|
||||
long int i_accumulator = 1;
|
||||
long double d_accumulator = 1;
|
||||
int is_int = true;
|
||||
struct cons_pointer result = make_integer( 1 );
|
||||
struct cons_pointer tmp;
|
||||
|
||||
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
|
||||
&& !exceptionp( result ); i++ ) {
|
||||
result =
|
||||
multiply_accumulate( frame->arg[i],
|
||||
frame,
|
||||
&i_accumulator, &d_accumulator, &is_int );
|
||||
tmp = result;
|
||||
result = multiply_2( frame, result, frame->arg[i] );
|
||||
|
||||
if ( !eq( tmp, result ) ) {
|
||||
dec_ref( tmp );
|
||||
}
|
||||
}
|
||||
|
||||
struct cons_pointer more = frame->more;
|
||||
while ( consp( more )
|
||||
&& !exceptionp( result ) ) {
|
||||
result =
|
||||
multiply_accumulate( c_car
|
||||
( more ),
|
||||
frame,
|
||||
&i_accumulator, &d_accumulator, &is_int );
|
||||
tmp = result;
|
||||
result = multiply_2( frame, result, c_car( more ) );
|
||||
if ( !eq( tmp, result ) ) {
|
||||
dec_ref( tmp );
|
||||
}
|
||||
|
||||
more = c_cdr( more );
|
||||
}
|
||||
|
||||
if ( !exceptionp( result ) ) {
|
||||
if ( is_int ) {
|
||||
result = make_integer( i_accumulator );
|
||||
} else {
|
||||
result = make_real( d_accumulator );
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
struct cons_pointer inverse( struct stack_frame *frame,
|
||||
struct cons_pointer arg ) {
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_space_object cell = pointer2cell( arg );
|
||||
|
||||
switch ( cell.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = arg;
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result = make_integer( 0 - to_long_int( arg ) );
|
||||
break;
|
||||
case NILTV:
|
||||
result = TRUE;
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = make_ratio( frame,
|
||||
make_integer( 0 -
|
||||
to_long_int( cell.payload.
|
||||
ratio.dividend ) ),
|
||||
cell.payload.ratio.divisor );
|
||||
break;
|
||||
case REALTV:
|
||||
result = make_real( 0 - to_long_double( arg ) );
|
||||
break;
|
||||
case TRUETV:
|
||||
result = NIL;
|
||||
break;
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame,
|
||||
struct cons_pointer arg1,
|
||||
struct cons_pointer arg2 ) {
|
||||
struct cons_pointer i = inverse( frame, arg2 ),
|
||||
result = add_ratio_ratio( frame, arg1, i );
|
||||
|
||||
dec_ref( i );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* Subtract one number from another.
|
||||
* @param env the evaluation environment - ignored;
|
||||
|
@ -411,32 +581,83 @@ struct cons_pointer lisp_subtract( struct
|
|||
*frame, struct
|
||||
cons_pointer env ) {
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
|
||||
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
|
||||
if ( integerp( frame->arg[0] )
|
||||
&& integerp( frame->arg[1] ) ) {
|
||||
struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
|
||||
struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
|
||||
|
||||
switch ( cell0.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = frame->arg[0];
|
||||
break;
|
||||
case INTEGERTV:
|
||||
switch ( cell1.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = frame->arg[1];
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result = make_integer( cell0.payload.integer.value
|
||||
- cell1.payload.integer.value );
|
||||
break;
|
||||
case RATIOTV:{
|
||||
struct cons_pointer tmp =
|
||||
make_ratio( frame, frame->arg[0],
|
||||
make_integer( 1 ) );
|
||||
result =
|
||||
make_integer( arg0.payload.integer.value
|
||||
- arg1.payload.integer.value );
|
||||
} else if ( realp( frame->arg[0] )
|
||||
&& realp( frame->arg[1] ) ) {
|
||||
subtract_ratio_ratio( frame, tmp, frame->arg[1] );
|
||||
dec_ref( tmp );
|
||||
}
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( arg0.payload.real.value - arg1.payload.real.value );
|
||||
} else if ( integerp( frame->arg[0] )
|
||||
&& realp( frame->arg[1] ) ) {
|
||||
make_real( to_long_double( frame->arg[0] ) -
|
||||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case RATIOTV:
|
||||
switch ( cell1.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
result = frame->arg[1];
|
||||
break;
|
||||
case INTEGERTV:{
|
||||
struct cons_pointer tmp =
|
||||
make_ratio( frame, frame->arg[1],
|
||||
make_integer( 1 ) );
|
||||
result =
|
||||
make_real( numeric_value
|
||||
( frame->arg[0] ) - arg1.payload.real.value );
|
||||
} else if ( realp( frame->arg[0] )
|
||||
&& integerp( frame->arg[1] ) ) {
|
||||
subtract_ratio_ratio( frame, frame->arg[0], tmp );
|
||||
dec_ref( tmp );
|
||||
}
|
||||
break;
|
||||
case RATIOTV:
|
||||
result =
|
||||
make_real( arg0.payload.real.value -
|
||||
numeric_value( frame->arg[1] ) );
|
||||
} else {
|
||||
/* TODO: throw an exception */
|
||||
lisp_throw
|
||||
( c_string_to_lisp_string
|
||||
( "Cannot subtract: not a number" ), frame );
|
||||
subtract_ratio_ratio( frame, frame->arg[0],
|
||||
frame->arg[1] );
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( to_long_double( frame->arg[0] ) -
|
||||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ),
|
||||
frame );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case REALTV:
|
||||
result =
|
||||
make_real( to_long_double( frame->arg[0] ) -
|
||||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Cannot multiply: not a number" ), frame );
|
||||
break;
|
||||
}
|
||||
|
||||
// and if not nilp[frame->arg[2]) we also have an error.
|
||||
|
|
Loading…
Reference in a new issue