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

Ratio multiplication and subtraction

Browse source
This commit is contained in:
Simon Brooke 2018-12-24 10:28:10 +00:00
parent d725097f89
commit 7e98207f7e
3 changed files with 342 additions and 112 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
src/conspage.c
View file

@ -127,6 +127,9 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) { void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other /* for all the types of cons-space object which point to other
* cons-space objects, cascade the decrement. */ * cons-space objects, cascade the decrement. */
@ -160,20 +163,18 @@ void free_cell( struct cons_pointer pointer ) {
if ( !check_tag( pointer, FREETAG ) ) { if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) { if ( cell->count == 0 ) {
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
strncpy( &cell->tag.bytes[0], FREETAG, 4 ); strncpy( &cell->tag.bytes[0], FREETAG, 4 );
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist = pointer; freelist = pointer;
} else { } else {
fwprintf( stderr, 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 ); cell->count, pointer.page, pointer.offset );
} }
} else { } else {
fwprintf( stderr, 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 ); pointer.page, pointer.offset );
} }
} }

8
src/consspaceobject.c
View file

@ -133,6 +133,14 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L";\n\t\t\tbody: " ); fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body ); print( output, cell.payload.lambda.body );
break; 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: case READTV:
fwprintf( output, L"\t\tInput stream\n" ); fwprintf( output, L"\t\tInput stream\n" );
case REALTV: case REALTV:

437
src/peano.c
View file

@ -26,7 +26,7 @@
#include "stack.h" #include "stack.h"
long double to_long_double( struct cons_pointer arg ); 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 add_2( struct stack_frame *frame, struct cons_pointer arg1,
struct cons_pointer arg2 ); 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 * 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. * 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; long int result = 0;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) { 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; 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 * return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * 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 ); fputws( L"; arg2 = ", stderr );
print( stderr, arg2 ); print( stderr, arg2 );
struct cons_pointer result; struct cons_pointer r1, result;
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 );
long int dd1v = long int dd1v =
@ -158,35 +180,22 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
result = r1 = make_ratio( frame,
make_ratio( frame, make_integer( dd1v + dd2v ),
make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor );
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 { } else {
result = add_ratio_ratio( frame, r1 = add_ratio_ratio( frame,
make_ratio( frame, make_ratio( frame,
make_integer( dd1v * m1 ), make_integer( dd1v * m1 ),
make_integer( dr1v * m1 ) ), make_integer( dr1v * m1 ) ),
make_ratio( frame, make_ratio( frame,
make_integer( dd2v * m2 ), make_integer( dd2v * m2 ),
make_integer( dr2v * m2 ) ) ); make_integer( dr2v * m2 ) ) );
}
result = simplify_ratio( frame, r1 );
if ( !eq( r1, result ) ) {
dec_ref( r1 );
} }
fputws( L" => ", stderr ); fputws( L" => ", 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 result = lisp_throw( c_string_to_lisp_string
( "Cannot add: not a number" ), ( "Cannot add: not a number" ),
frame ); frame );
break;
} }
break; break;
case RATIOTV: 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 ) + make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot add: not a number" ),
frame );
break;
} }
break; break;
case REALTV: case REALTV:
@ -292,7 +307,6 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
print( stderr, arg2 ); print( stderr, arg2 );
fputws( L"\n", stderr ); fputws( L"\n", stderr );
return result; return result;
} }
@ -306,56 +320,173 @@ struct cons_pointer lisp_add( struct stack_frame
*frame, struct *frame, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = make_integer( 0 ); struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp;
for ( int i = 0; for ( int i = 0;
i < args_in_frame && i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result;
result = add_2( frame, result, frame->arg[i] ); result = add_2( frame, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
} }
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) { while ( consp( more ) && !exceptionp( result ) ) {
tmp = result;
result = add_2( frame, result, c_car( more ) ); result = add_2( frame, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more ); more = c_cdr( more );
} }
return result; return result;
} }
/** struct cons_pointer multiply_ratio_ratio( struct
* Internal guts of multiply. Dark and mysterious. stack_frame
*/ *frame, struct
struct cons_pointer multiply_accumulate( struct cons_pointer arg1, struct
cons_pointer arg, struct cons_pointer arg2 ) {
stack_frame fputws( L"multiply_ratio_ratio( arg1 = ", stderr );
*frame, long print( stderr, arg1 );
int fputws( L"; arg2 = ", stderr );
*i_accumulator, long print( stderr, arg2 );
double
*d_accumulator, int struct cons_pointer result;
*is_int ) { struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_pointer result = NIL; struct cons_space_object cell2 = pointer2cell( arg2 );
struct cons_space_object cell = pointer2cell( arg ); long int dd1v =
switch ( cell.tag.value ) { pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
case INTEGERTV: dd2v =
( *i_accumulator ) *= cell.payload.integer.value; pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
( *d_accumulator ) *= numeric_value( arg ); dr1v =
break; pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
case REALTV: dr2v =
( *d_accumulator ) *= cell.payload.real.value; pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
( *is_int ) &= false; ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
break;
case EXCEPTIONTV: struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ),
result = arg; make_integer( drrv ) );
break; result = simplify_ratio( frame, unsimplified );
default:
result = if ( !eq( unsimplified, result ) ) {
lisp_throw dec_ref( unsimplified );
( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
} }
return result; 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 * Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
@ -366,40 +497,79 @@ struct cons_pointer lisp_multiply( struct
stack_frame stack_frame
*frame, struct *frame, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = make_integer( 1 );
long int i_accumulator = 1; struct cons_pointer tmp;
long double d_accumulator = 1;
int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) { && !exceptionp( result ); i++ ) {
result = tmp = result;
multiply_accumulate( frame->arg[i], result = multiply_2( frame, result, frame->arg[i] );
frame,
&i_accumulator, &d_accumulator, &is_int ); if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
} }
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) while ( consp( more )
&& !exceptionp( result ) ) { && !exceptionp( result ) ) {
result = tmp = result;
multiply_accumulate( c_car result = multiply_2( frame, result, c_car( more ) );
( more ), if ( !eq( tmp, result ) ) {
frame, dec_ref( tmp );
&i_accumulator, &d_accumulator, &is_int ); }
more = c_cdr( more ); more = c_cdr( more );
} }
if ( !exceptionp( result ) ) { return result;
if ( is_int ) { }
result = make_integer( i_accumulator );
} else { struct cons_pointer inverse( struct stack_frame *frame,
result = make_real( d_accumulator ); 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; 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. * Subtract one number from another.
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
@ -411,32 +581,83 @@ struct cons_pointer lisp_subtract( struct
*frame, struct *frame, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
if ( integerp( frame->arg[0] )
&& integerp( frame->arg[1] ) ) { switch ( cell0.tag.value ) {
result = case EXCEPTIONTV:
make_integer( arg0.payload.integer.value result = frame->arg[0];
- arg1.payload.integer.value ); break;
} else if ( realp( frame->arg[0] ) case INTEGERTV:
&& realp( frame->arg[1] ) ) { switch ( cell1.tag.value ) {
result = case EXCEPTIONTV:
make_real( arg0.payload.real.value - arg1.payload.real.value ); result = frame->arg[1];
} else if ( integerp( frame->arg[0] ) break;
&& realp( frame->arg[1] ) ) { case INTEGERTV:
result = result = make_integer( cell0.payload.integer.value
make_real( numeric_value - cell1.payload.integer.value );
( frame->arg[0] ) - arg1.payload.real.value ); break;
} else if ( realp( frame->arg[0] ) case RATIOTV:{
&& integerp( frame->arg[1] ) ) { struct cons_pointer tmp =
result = make_ratio( frame, frame->arg[0],
make_real( arg0.payload.real.value - make_integer( 1 ) );
numeric_value( frame->arg[1] ) ); result =
} else { subtract_ratio_ratio( frame, tmp, frame->arg[1] );
/* TODO: throw an exception */ dec_ref( tmp );
lisp_throw }
( c_string_to_lisp_string break;
( "Cannot subtract: not a number" ), frame ); 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 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 =
subtract_ratio_ratio( frame, frame->arg[0], tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result =
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. // and if not nilp[frame->arg[2]) we also have an error.