diff --git a/src/arith/integer.c b/src/arith/integer.c index 999c803..e069f52 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -13,7 +13,6 @@ #include "conspage.h" #include "consspaceobject.h" -#include "read.h" /** * return the numeric value of this cell, as a C primitive double, not @@ -41,7 +40,9 @@ struct cons_pointer make_integer( long int value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; +#ifdef DEBUG dump_object( stderr, result ); +#endif return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 39613f5..d43c768 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -21,6 +21,7 @@ #include "intern.h" #include "lispops.h" #include "print.h" +#include "ratio.h" #include "read.h" #include "real.h" #include "stack.h" @@ -113,123 +114,6 @@ long int to_long_int( struct cons_pointer arg ) { return result; } -long int greatest_common_divisor( long int m, long int n ) { - int o; - while ( m ) { - o = m; - m = n % m; - n = o; - } - - return o; -} - -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, -* this is going to break horribly. -*/ -struct cons_pointer add_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - fputws( L"add_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - - struct cons_pointer r, 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, - lcm = least_common_multiple( dr1v, dr2v ), - m1 = lcm / dr1v, m2 = lcm / dr2v; - - fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); - - if ( dr1v == dr2v ) { - r = make_ratio( frame, - make_integer( dd1v + dd2v ), - cell1.payload.ratio.divisor ); - } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1 ), - dr1vm = make_integer( dr1v * m1 ), - dd2vm = make_integer( dd2v * m2 ), - dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame, dd1vm, dr1vm ), - r2 = make_ratio( frame, dd2vm, dr2vm ); - - r = add_ratio_ratio( frame, r1, r2 ); - - /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were - * never incremented except when making r1 and r2, decrementing - * r1 and r2 should be enought to garbage collect them. */ - dec_ref( r1 ); - dec_ref( r2 ); - } - - result = simplify_ratio( frame, r ); - if ( !eq( r, result ) ) { - dec_ref( r ); - } - - fputws( L" => ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); - - 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 add_integer_ratio( struct stack_frame *frame, - struct cons_pointer intarg, - struct cons_pointer ratarg ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ), - result = add_ratio_ratio( frame, ratio, ratarg ); - - dec_ref( one ); - dec_ref( ratio ); - return result; -} - /** * return a cons_pointer indicating a number which is the sum of @@ -358,58 +242,6 @@ struct cons_pointer lisp_add( struct stack_frame return result; } -struct cons_pointer multiply_ratio_ratio( struct - stack_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 ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ), - result = multiply_ratio_ratio( frame, ratio, ratarg ); - - dec_ref( one ); - dec_ref( ratio ); - - return result; -} - /** * return a cons_pointer indicating a number which is the product of @@ -543,6 +375,10 @@ struct cons_pointer lisp_multiply( struct return result; } +/** + * return a cons_pointer indicating a number which is the + * inverse of the number indicated by `arg`. + */ struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer arg ) { struct cons_pointer result = NIL; @@ -577,17 +413,6 @@ struct cons_pointer inverse( struct stack_frame *frame, } -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; @@ -683,26 +508,6 @@ struct cons_pointer lisp_subtract( struct return result; } -/** - * return a cons_pointer to a ratio which represents the value of the ratio - * indicated by `arg1` divided by the ratio indicated by `arg2`. If either - * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. - */ -struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer i = make_ratio( frame, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = - multiply_ratio_ratio( frame, arg1, i ); - - dec_ref( i ); - - return result; -} - /** * Divide one number by another. * @param env the evaluation environment - ignored; diff --git a/src/arith/ratio.c b/src/arith/ratio.c new file mode 100644 index 0000000..28ba59a --- /dev/null +++ b/src/arith/ratio.c @@ -0,0 +1,330 @@ +/* + * ratio.c + * + * functions for rational number cells. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#define _GNU_SOURCE +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "equal.h" +#include "integer.h" +#include "lispops.h" +#include "print.h" +#include "ratio.h" + + +/* + * declared in peano.c, can't include piano.h here because + * circularity. TODO: refactor. + */ +struct cons_pointer inverse( struct stack_frame *frame, + struct cons_pointer arg ); + +/** + * return, as a long int, the greatest common divisor of `m` and `n`, + */ +long int greatest_common_divisor( long int m, long int n ) { + int o; + while ( m ) { + o = m; + m = n % m; + n = o; + } + + return o; +} + +/** + * return, as a long int, the least common multiple of `m` and `n`, + */ +long int least_common_multiple( long int m, long int n ) { + return m / greatest_common_divisor( m, n ) * n; +} + +/** + * return a cons_pointer indicating a number which is of the + * same value as the ratio indicated by `arg`, but which may + * be in a simplified representation. If `arg` isn't a ratio, + * will throw exception. + */ +struct cons_pointer simplify_ratio( struct stack_frame *frame, + struct cons_pointer arg ) { + struct cons_pointer result = arg; + + if (ratiop(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 ) ); + } + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to simplify_ratio" ), + frame ); + } + + 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 add_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer r, result; + +#ifdef DEBUG + fputws( L"add_ratio_ratio( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif + + if ( ratiop(arg1) && ratiop(arg2)) { + 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, + lcm = least_common_multiple( dr1v, dr2v ), + m1 = lcm / dr1v, m2 = lcm / dr2v; + +#ifdef DEBUG + fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); +#endif + + if ( dr1v == dr2v ) { + r = make_ratio( frame, + make_integer( dd1v + dd2v ), + cell1.payload.ratio.divisor ); + } else { + struct cons_pointer dd1vm = make_integer( dd1v * m1 ), + dr1vm = make_integer( dr1v * m1 ), + dd2vm = make_integer( dd2v * m2 ), + dr2vm = make_integer( dr2v * m2 ), + r1 = make_ratio( frame, dd1vm, dr1vm ), + r2 = make_ratio( frame, dd2vm, dr2vm ); + + r = add_ratio_ratio( frame, r1, r2 ); + + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were + * never incremented except when making r1 and r2, decrementing + * r1 and r2 should be enought to garbage collect them. */ + dec_ref( r1 ); + dec_ref( r2 ); + } + + result = simplify_ratio( frame, r ); + if ( !eq( r, result ) ) { + dec_ref( r ); + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to add_ratio_ratio" ), + frame ); + } + +#ifdef DEBUG + fputws( L" => ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); +#endif + + return result; +} + + +/** + * return a cons_pointer indicating a number which is the sum of + * the intger indicated by `intarg` and the ratio indicated by + * `ratarg`. If you pass other types, this is going to break horribly. + */ +struct cons_pointer add_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if (integerp(intarg) && ratiop(ratarg)) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); + + result = add_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to add_integer_ratio" ), + frame ); + } + + return result; +} + +/** + * return a cons_pointer to a ratio which represents the value of the ratio + * indicated by `arg1` divided by the ratio indicated by `arg2`. If either + * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. + */ +struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = make_ratio( frame, + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = + multiply_ratio_ratio( frame, arg1, i ); + + dec_ref( i ); + + return result; +} + +/** + * return a cons_pointer indicating a number which is the product of + * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, + * this is going to break horribly. + */ +struct cons_pointer multiply_ratio_ratio( struct + stack_frame + *frame, struct + cons_pointer arg1, struct + cons_pointer arg2 ) { + struct cons_pointer result; + +#ifdef DEBUG + fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif + if ( ratiop(arg1) && ratiop(arg2)) { + 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 ); + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame ); + } + + return result; +} + +/** + * return a cons_pointer indicating a number which is the product of + * the intger indicated by `intarg` and the ratio indicated by + * `ratarg`. If you pass other types, this is going to break horribly. + */ +struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if (integerp(intarg) && ratiop(ratarg)) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); + result = multiply_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame ); + } + + return result; +} + + +/** + * return a cons_pointer indicating a number which is the difference of + * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, + * this is going to break horribly. + */ +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; +} + + +/** + * Construct a ratio frame from these two pointers, expected to be integers + * or (later) bignums, in the context of this stack_frame. + */ +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ) { + struct cons_pointer result; + if ( integerp( dividend ) && integerp( divisor ) ) { + inc_ref( dividend ); + inc_ref( divisor ); + result = allocate_cell( RATIOTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.ratio.dividend = dividend; + cell->payload.ratio.divisor = divisor; + } else { + result = + lisp_throw( c_string_to_lisp_string + ( "Dividend and divisor of a ratio must be integers" ), + frame ); + } +#ifdef DEBUG + dump_object( stderr, result ); +#endif + + return result; +} diff --git a/src/arith/ratio.h b/src/arith/ratio.h new file mode 100644 index 0000000..fe650a7 --- /dev/null +++ b/src/arith/ratio.h @@ -0,0 +1,48 @@ +/** + * ratio.h + * + * functions for rational number cells. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __ratio_h +#define __ratio_h + +struct cons_pointer simplify_ratio( struct stack_frame *frame, + struct cons_pointer arg ) ; + +struct cons_pointer add_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer add_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) ; + +struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer multiply_ratio_ratio( struct + stack_frame + *frame, struct + cons_pointer arg1, struct + cons_pointer arg2 ) ; + +struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) ; + +struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ) ; + + +#endif diff --git a/src/arith/real.c b/src/arith/real.c index 526dca5..ea3cc29 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -12,7 +12,7 @@ #include "read.h" /** - * Allocate a real number cell representing this value and return a cons + * Allocate a real number cell representing this value and return a cons * pointer to it. * @param value the value to wrap; * @return a real number cell wrapping this value. @@ -22,5 +22,9 @@ struct cons_pointer make_real( long double value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; - return result; +#ifdef DEBUG + dump_object( stderr, result ); +#endif + + return result; } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index d927470..96f2cdd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -247,31 +247,6 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } -/** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. - */ -struct cons_pointer make_ratio( struct stack_frame *frame, - struct cons_pointer dividend, - struct cons_pointer divisor ) { - struct cons_pointer result; - if ( integerp( dividend ) && integerp( divisor ) ) { - inc_ref( dividend ); - inc_ref( divisor ); - result = allocate_cell( RATIOTAG ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.ratio.dividend = dividend; - cell->payload.ratio.divisor = divisor; - } else { - result = - make_exception( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), - frame ); - } - - return result; -} - /** * Construct a string from this character (which later will be UTF) and * this tail. A string is implemented as a flat list of cells each of which diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 371779c..5dae587 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -129,8 +129,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { * used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { - struct cons_pointer body = - !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL; + struct cons_pointer body = frame->more; for ( int i = args_in_frame - 1; i > 0; i-- ) { if ( !nilp( body ) ) { diff --git a/src/ops/read.c b/src/ops/read.c index 458c3f8..e5a41a5 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -22,6 +22,7 @@ #include "intern.h" #include "lispops.h" #include "print.h" +#include "ratio.h" #include "read.h" #include "real.h"