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

Moved legacy code into archive, ready for a new rapid(?) prototype.

Browse source 
I may regret doing this!
This commit is contained in:
Simon Brooke 2026-03-24 16:25:09 +00:00
parent 09051a3e63
commit 914c35ead0
114 changed files with 165 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

508
archive/c/arith/integer.c Normal file
View file

@ -0,0 +1,508 @@
/*
* integer.c
*
* functions for integer cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <limits.h>
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "ops/equal.h"
#include "ops/lispops.h"
/**
* hexadecimal digits for printing numbers.
*/
const char *hex_digits = "0123456789ABCDEF";
/*
* Doctrine from here on in is that ALL integers are bignums, it's just
* that integers less than 61 bits are bignums of one cell only.
* that integers less than 61 bits are bignums of one cell only.
* TODO: why do I not have confidence to make this 64 bits?
*/
/*
* A small_int_cache array of pointers to the integers 0...23,
* used only by functions `acquire_integer(int64) => cons_pointer` and
* `release_integer(cons_pointer) => NULL` which, if the value desired is
* in the cache, supplies it from the cache, and, otherwise, calls
* make_integer() and dec_ref() respectively.
*/
#define SMALL_INT_LIMIT 24
bool small_int_cache_initialised = false;
struct cons_pointer small_int_cache[SMALL_INT_LIMIT];
/**
* Low level integer arithmetic, do not use elsewhere.
*
* @param c a pointer to a cell, assumed to be an integer cell;
* @param op a character representing the operation: expected to be either
* '+' or '*'; behaviour with other values is undefined.
* @param is_first_cell true if this is the first cell in a bignum
* chain, else false.
* \see multiply_integers
* \see add_integers
*/
__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value;
long int carry = is_first_cell ? 0 : ( INT_CELL_BASE );
__int128_t result = ( __int128_t ) integerp( c ) ?
( val == 0 ) ? carry : val : op == '*' ? 1 : 0;
debug_printf( DEBUG_ARITH,
L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ",
val, is_first_cell ? "true" : "false",
pointer2cell( c ).tag.bytes );
debug_print_128bit( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* Allocate an integer cell representing this `value` and return a cons_pointer to it.
* @param value an integer value;
* @param more `NIL`, or a pointer to the more significant cell(s) of this number.
* *NOTE* that if `more` is not `NIL`, `value` *must not* exceed `MAX_INTEGER`.
*/
struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result = NIL;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC );
if ( integerp( more )
&& ( pointer2cell( more ).payload.integer.value < 0 ) ) {
printf( "WARNING: negative value %" PRId64
" passed as `more` to `make_integer`\n",
pointer2cell( more ).payload.integer.value );
}
if ( integerp( more ) || nilp( more ) ) {
result = allocate_cell( INTEGERTV );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
cell->payload.integer.more = more;
}
debug_print( L"make_integer: returning\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC );
return result;
}
/**
* @brief Supply small valued integers from the small integer cache, if available.
*
* The pattern here is intended to be that, at least within this file, instead of
* calling make_integer when an integer is required and dec_ref when it's no longer
* required, we call acquire_integer and release_integer respectively, in order to
* reduce allocation churn.
*
* In the initial implementation, acquire_integer supplies the integer from the
* small integer cache if available, else calls make_integer. Later, more
* sophisticated caching of integers which are currently in play may be enabled.
*
* @param value the value of the integer desired.
* @param more if this value is a bignum, the rest (less significant bits) of the
* value.
* @return struct cons_pointer a pointer to the integer acquired.
*/
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result;
if ( !nilp( more ) || value < 0 || value >= SMALL_INT_LIMIT ) {
debug_print
( L"acquire_integer passing to make_integer (outside small int range)\n",
DEBUG_ALLOC );
result = make_integer( value, more );
} else {
if ( !small_int_cache_initialised ) {
for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) {
small_int_cache[i] = make_integer( i, NIL );
pointer2cell( small_int_cache[i] ).count = MAXREFERENCE; // lock it in so it can't be GC'd
}
small_int_cache_initialised = true;
debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC );
}
debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n",
value );
result = small_int_cache[value];
}
return result;
}
/**
* @brief if the value of p is less than the size of the small integer cache
* (and thus it was presumably supplied from there), suppress dec_ref.
*
* **NOTE THAT** at this stage it's still safe to dec_ref an arbitrary integer,
* because those in the cache are locked and can't be dec_refed.
*
* @param p a pointer, expected to be to an integer.
*/
void release_integer( struct cons_pointer p ) {
struct cons_space_object o = pointer2cell( p );
if ( !integerp( p ) || // what I've been passed isn't an integer;
!nilp( o.payload.integer.more ) || // or it's a bignum;
o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit;
!eq( p, small_int_cache[o.payload.integer.value] ) // or it's simply not the copy in the cache...
) {
dec_ref( p );
} else {
debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n",
o.payload.integer.value );
}
}
/**
* @brief Overwrite the value field of the integer indicated by `new` with
* the least significant INTEGER_BITS bits of `val`, and return the
* more significant bits (if any) right-shifted by INTEGER_BITS places.
*
* Destructive, primitive, DO NOT USE in any context except primitive
* operations on integers. The value passed as `new` MUST be constructed
* with `make_integer`, NOT acquired with `acquire_integer`.
*
* @param val the value to represent;
* @param less_significant the less significant words of this bignum, if any,
* else NIL;
* @param new a newly created integer, which will be destructively changed.
* @return carry, if any, else 0.
*/
__int128_t int128_to_integer( __int128_t val,
struct cons_pointer less_significant,
struct cons_pointer new ) {
__int128_t carry = 0;
if ( MAX_INTEGER >= val ) {
carry = 0;
} else {
carry = val % INT_CELL_BASE;
debug_printf( DEBUG_ARITH,
L"int128_to_integer: 64 bit overflow; setting carry to %ld\n",
( int64_t ) carry );
val /= INT_CELL_BASE;
}
struct cons_space_object *newc = &pointer2cell( new );
newc->payload.integer.value = ( int64_t ) val;
if ( integerp( less_significant ) ) {
struct cons_space_object *lsc = &pointer2cell( less_significant );
// inc_ref( new );
lsc->payload.integer.more = new;
}
return carry;
}
/**
* Return a pointer to an integer representing the sum of the integers
* pointed to by `a` and `b`. If either isn't an integer, will return nil.
*/
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b ) {
struct cons_pointer result = NIL;
struct cons_pointer cursor = NIL;
__int128_t carry = 0;
bool is_first_cell = true;
while ( integerp( a ) || integerp( b ) || carry != 0 ) {
__int128_t av = cell_value( a, '+', is_first_cell );
__int128_t bv = cell_value( b, '+', is_first_cell );
__int128_t rv = ( av + bv ) + carry;
debug_print( L"add_integers: av = ", DEBUG_ARITH );
debug_print_128bit( av, DEBUG_ARITH );
debug_print( L"; bv = ", DEBUG_ARITH );
debug_print_128bit( bv, DEBUG_ARITH );
debug_print( L"; carry = ", DEBUG_ARITH );
debug_print_128bit( carry, DEBUG_ARITH );
debug_print( L"; rv = ", DEBUG_ARITH );
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );
carry = int128_to_integer( rv, cursor, new );
cursor = new;
if ( nilp( result ) ) {
result = cursor;
}
a = pointer2cell( a ).payload.integer.more;
b = pointer2cell( b ).payload.integer.more;
is_first_cell = false;
}
}
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea.
struct cons_pointer base_partial( int depth ) {
struct cons_pointer result = NIL;
debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth );
for ( int i = 0; i < depth; i++ ) {
result = acquire_integer( 0, result );
}
return result;
}
/**
* @brief Return a copy of this `partial` with this `digit` appended.
*
* @param partial the more significant bits of a possible bignum.
* @param digit the less significant bits of that possible bignum. NOTE: the
* name `digit` is technically correct but possibly misleading, because the
* numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL
*/
struct cons_pointer append_cell( struct cons_pointer partial,
struct cons_pointer digit ) {
struct cons_space_object cell = pointer2cell( partial );
// TODO: I should recursively copy the whole bignum chain, because
// we're still destructively modifying the end of it.
struct cons_pointer c = make_integer( cell.payload.integer.value,
cell.payload.integer.more );
struct cons_pointer result = partial;
if ( nilp( partial ) ) {
result = digit;
} else {
// find the last digit in the chain...
while ( !nilp( pointer2cell( c ).payload.integer.more ) ) {
c = pointer2cell( c ).payload.integer.more;
}
( pointer2cell( c ) ).payload.integer.more = digit;
}
return result;
}
/**
* Return a pointer to an integer representing the product of the integers
* pointed to by `a` and `b`. If either isn't an integer, will return nil.
*
* Yes, this is one of Muhammad ibn Musa al-Khwarizmi's original recipes, so
* you'd think it would be easy; the reason that each step is documented is
* because I did not find it so.
*
* @param a an integer;
* @param b an integer.
*/
struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b ) {
struct cons_pointer result = acquire_integer( 0, NIL );
bool neg = is_negative( a ) != is_negative( b );
bool is_first_b = true;
int i = 0;
debug_print( L"multiply_integers: a = ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L"; b = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
if ( integerp( a ) && integerp( b ) ) {
/* for each digit in a, starting with the least significant (ai) */
for ( struct cons_pointer ai = a; !nilp( ai );
ai = pointer2cell( ai ).payload.integer.more ) {
/* set carry to 0 */
__int128_t carry = 0;
/* set least significant digits for result ri for this iteration
* to i zeros */
struct cons_pointer ri = base_partial( i++ );
/* for each digit in b, starting with the least significant (bj) */
for ( struct cons_pointer bj = b; !nilp( bj );
bj = pointer2cell( bj ).payload.integer.more ) {
debug_printf( DEBUG_ARITH,
L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n",
pointer2cell( ai ).payload.integer.value,
pointer2cell( bj ).payload.integer.value, i );
/* multiply ai with bj and add the carry, resulting in a
* value xj which may exceed one digit */
__int128_t xj = pointer2cell( ai ).payload.integer.value *
pointer2cell( bj ).payload.integer.value;
xj += carry;
/* if xj exceeds one digit, break it into the digit dj and
* the carry */
carry = xj >> INTEGER_BIT_SHIFT;
struct cons_pointer dj =
acquire_integer( xj & MAX_INTEGER, NIL );
replace_integer_p( ri, append_cell( ri, dj ) );
// struct cons_pointer new_ri = append_cell( ri, dj );
// release_integer( ri);
// ri = new_ri;
} /* end for bj */
/* if carry is not equal to zero, append it as a final cell
* to ri */
if ( carry != 0 ) {
replace_integer_i( ri, carry )
}
/* add ri to result */
result = add_integers( result, ri );
debug_print( L"multiply_integers: result is ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
} /* end for ai */
}
debug_print( L"multiply_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* don't use; private to integer_to_string, and somewhat dodgy.
*/
struct cons_pointer integer_to_string_add_digit( int digit, int digits,
struct cons_pointer tail ) {
wint_t character = btowc( hex_digits[digit] );
debug_printf( DEBUG_IO,
L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ",
digit, digits );
struct cons_pointer r =
( digits % 3 == 0 ) ? make_string( L',', make_string( character,
tail ) ) :
make_string( character, tail );
debug_print_object( r, DEBUG_IO );
debug_println( DEBUG_IO );
return r;
}
/**
* @brief return a string representation of this integer, which may be a
* bignum.
*
* The general principle of printing a bignum is that you print the least
* significant digit in whatever base you're dealing with, divide through
* by the base, print the next, and carry on until you've none left.
* Obviously, that means you print from right to left. Given that we build
* strings from right to left, 'printing' an integer to a lisp string
* would seem reasonably easy. The problem is when you jump from one integer
* object to the next. 64 bit integers don't align with decimal numbers, so
* when we get to the last digit from one integer cell, we have potentially
* to be looking to the next. H'mmmm.
*
* @param int_pointer cons_pointer to the integer to print,
* @param base the base to print it in.
*/
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base ) {
struct cons_pointer result = NIL;
if ( integerp( int_pointer ) ) {
struct cons_pointer next =
pointer2cell( int_pointer ).payload.integer.more;
__int128_t accumulator =
llabs( pointer2cell( int_pointer ).payload.integer.value );
bool is_negative =
pointer2cell( int_pointer ).payload.integer.value < 0;
int digits = 0;
if ( accumulator == 0 && nilp( next ) ) {
result = c_string_to_lisp_string( L"0" );
} else {
while ( accumulator > 0 || !nilp( next ) ) {
if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
accumulator +=
( pointer2cell( next ).payload.integer.value %
INT_CELL_BASE );
next = pointer2cell( next ).payload.integer.more;
}
int offset = ( int ) ( accumulator % base );
debug_printf( DEBUG_IO,
L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ",
offset, hex_digits[offset] );
debug_print_128bit( accumulator, DEBUG_IO );
debug_print( L"; result is: ", DEBUG_IO );
debug_print_object( result, DEBUG_IO );
debug_println( DEBUG_IO );
result =
integer_to_string_add_digit( offset, ++digits, result );
accumulator = accumulator / base;
}
if ( stringp( result )
&& pointer2cell( result ).payload.string.character == L',' ) {
/* if the number of digits in the string is divisible by 3, there will be
* an unwanted comma on the front. */
result = pointer2cell( result ).payload.string.cdr;
}
if ( is_negative ) {
result = make_string( L'-', result );
}
}
}
return result;
}
/**
* true if a and be are both integers whose value is the same value.
*/
bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( integerp( a ) && integerp( b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
result =
cell_a->payload.integer.value == cell_b->payload.integer.value;
}
return result;
}

41
archive/c/arith/integer.h Normal file
View file

@ -0,0 +1,41 @@
/*
* integer.h
*
* functions for integer cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __integer_h
#define __integer_h
#include <stdbool.h>
#include <stdint.h>
#include "memory/consspaceobject.h"
#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;}
#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;}
struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more );
void release_integer( struct cons_pointer p );
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b );
struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b );
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base );
bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b );
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b );
#endif

825
archive/c/arith/peano.c Normal file
View file

@ -0,0 +1,825 @@
/*
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h"
#include "ops/equal.h"
#include "arith/integer.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "arith/peano.h"
#include "io/print.h"
#include "arith/ratio.h"
#include "io/read.h"
#include "arith/real.h"
#include "memory/stack.h"
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
/**
* return true if this `arg` points to a number whose value is zero.
*/
bool zerop( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:{
do {
debug_print( L"zerop: ", DEBUG_ARITH );
debug_dump_object( arg, DEBUG_ARITH );
result =
( pointer2cell( arg ).payload.integer.value == 0 );
arg = pointer2cell( arg ).payload.integer.more;
} while ( result && integerp( arg ) );
}
break;
case RATIOTV:
result = zerop( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value == 0 );
break;
}
return result;
}
// TODO: think about
// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) {
// bool result = false;
// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
// if (cell_1->tag.value == cell_2->tag.value) {
// switch ( cell_1->tag.value ) {
// case INTEGERTV:{
// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) {
// result = cell_1->payload.integer.value > cell_2->payload.integer.value;
// }
// // else deal with comparing bignums...
// }
// break;
// case RATIOTV:
// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2);
// break;
// case REALTV:
// result = ( cell.payload.real.value == 0 );
// break;
// }
// }
// return result;
// }
/**
* does this `arg` point to a negative number?
*/
bool is_negative( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value < 0;
break;
case RATIOTV:
result = is_negative( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value < 0 );
break;
}
return result;
}
/**
* @brief if `arg` is a number, return the absolute value of that number, else
* `NIL`
*
* @param arg a cons space object, probably a number.
* @return struct cons_pointer
*/
struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
if ( numberp( arg ) ) {
if ( is_negative( arg ) ) {
switch ( cell.tag.value ) {
case INTEGERTV:
result =
make_integer( llabs( cell.payload.integer.value ),
cell.payload.integer.more );
break;
case RATIOTV:
result =
make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - cell.payload.real.value );
break;
}
} else {
result = arg;
}
}
return result;
}
/**
* Return the closest possible `binary64` representation to the value of
* this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg`
* is not any of these.
*
* @arg a pointer to an integer, ratio or real.
*
* \todo cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in.
*/
long double to_long_double( struct cons_pointer arg ) {
long double result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
// obviously, this doesn't work for bignums
result = ( long double ) cell.payload.integer.value;
// sadly, this doesn't work at all.
// result += 1.0;
// for (bool is_first = false; integerp(arg); is_first = true) {
// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result);
// debug_dump_object(arg, DEBUG_ARITH);
// if (!is_first) {
// result *= (long double)(MAX_INTEGER + 1);
// }
// result *= (long double)(cell.payload.integer.value);
// arg = cell.payload.integer.more;
// cell = pointer2cell( arg );
// }
break;
case RATIOTV:
result = to_long_double( cell.payload.ratio.dividend ) /
to_long_double( cell.payload.ratio.divisor );
break;
case REALTV:
result = cell.payload.real.value;
break;
default:
result = NAN;
break;
}
debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH );
debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result;
}
/**
* Return the closest possible `int64_t` representation to the value of
* this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg`
* is not any of these.
*
* @arg a pointer to an integer, ratio or real.
*
* \todo cannot throw an exception out of here, which is a problem
* 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.
*/
int64_t to_long_int( struct cons_pointer arg ) {
int64_t result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
/* \todo if (integerp(cell.payload.integer.more)) {
* throw an exception!
* } */
result = cell.payload.integer.value;
break;
case RATIOTV:
result = lroundl( to_long_double( arg ) );
break;
case REALTV:
result = lroundl( cell.payload.real.value );
break;
}
return result;
}
/**
* Function: calculate the absolute value of a number.
*
* (absolute arg)
*
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return the absolute value of the number represented by the first
* argument, or NIL if it was not a number.
*/
struct cons_pointer lisp_absolute( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return absolute( frame->arg[0] );
}
/**
* return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
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 );
debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
debug_dump_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_dump_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
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 = add_integers( arg1, arg2 );
break;
case RATIOTV:
result = add_integer_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = add_integer_ratio( arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
}
}
debug_print( L"}; => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if any argument is not a number, returns an exception.
*/
struct cons_pointer lisp_add( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 0, NIL );
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, frame_pointer, 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, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* 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 frame_pointer,
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 );
debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
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 = multiply_integers( arg1, arg2 );
break;
case RATIOTV:
result = multiply_integer_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ),
c_type( arg2 ) ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = multiply_integer_ratio( arg2, arg1 );
break;
case RATIOTV:
result = multiply_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ),
c_type( arg2 ) ),
frame_pointer );
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ),
frame_pointer );
break;
}
}
debug_print( L"multiply_2 returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if any argument is not a number, returns an exception.
*/
struct cons_pointer lisp_multiply( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 1, NIL );
struct cons_pointer tmp;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) {
debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"; arg = ", DEBUG_ARITH );
debug_print_object( frame->arg[i], DEBUG_ARITH );
debug_println( DEBUG_ARITH );
multiply_one_arg( frame->arg[i] );
}
struct cons_pointer more = frame->more;
while ( consp( more )
&& !exceptionp( result ) ) {
multiply_one_arg( c_car( more ) );
more = c_cdr( more );
}
debug_print( L"lisp_multiply returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the
* 0 - the number indicated by `arg`.
*/
struct cons_pointer negative( 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 - cell.payload.integer.value,
cell.payload.integer.more );
break;
case NILTV:
result = TRUE;
break;
case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
break;
case TRUETV:
result = NIL;
break;
}
return result;
}
/**
* Function: is this number negative?
*
* * (negative? arg)
*
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return T if the first argument was a negative number, or NIL if it
* was not.
*/
struct cons_pointer lisp_is_negative( struct stack_frame
*frame,
struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return is_negative( frame->arg[0] ) ? TRUE : NIL;
}
/**
* return a cons_pointer indicating a number which is the result of
* subtracting the number indicated by `arg2` from that indicated by `arg1`,
* in the context of this `frame`.
*/
struct cons_pointer subtract_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result = NIL;
switch ( pointer2cell( arg1 ).tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( pointer2cell( arg2 ).tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:{
struct cons_pointer i = negative( arg2 );
inc_ref( i );
result = add_integers( arg1, i );
dec_ref( i );
}
break;
case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1,
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) -
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( pointer2cell( arg2 ).tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1,
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result = subtract_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) -
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Subtract one number from another. If more than two arguments are passed
* in the frame, the additional arguments are ignored.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if either argument is not a number, returns an exception.
*/
struct cons_pointer lisp_subtract( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] );
}
/**
* Divide one number by another. If more than two arguments are passed
* in the frame, the additional arguments are ignored.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
* @exception if either argument is not a number, returns an exception.
*/
struct cons_pointer lisp_divide( struct
stack_frame
*frame, struct cons_pointer frame_pointer, 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] );
switch ( arg0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
result =
make_ratio( frame->arg[0], 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, false );
inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame->arg[1], one, false );
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio );
dec_ref( one );
}
break;
case RATIOTV:
result =
divide_ratio_ratio( 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 = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
return result;
}
/**
* @brief Function: return a real (approcimately) equal in value to the ratio
* which is the first argument.
*
* @param frame
* @param frame_pointer
* @param env
* @return struct cons_pointer a pointer to a real
*/
// 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 result = NIL;
struct cons_pointer rat = frame->arg[0];
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?
return result;
}

95
archive/c/arith/peano.h Normal file
View file

@ -0,0 +1,95 @@
/*
* peano.h
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef PEANO_H
#define PEANO_H
#include "memory/consspaceobject.h"
/**
* The maximum value we will allow in an integer cell: one less than 2^60:
* (let ((s (make-string-output-stream)))
* (format s "0x0~XL" (- (expt 2 60) 1))
* (string-downcase (get-output-stream-string s)))
* "0x0fffffffffffffffl"
*
* So left shifting and right shifting by 60 bits is correct.
*/
#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL)
#define INT_CELL_BASE ((__int128_t)MAX_INTEGER + 1) // ((__int128_t)0x1000000000000000L)
/**
* @brief Number of value bits in an integer cell
*
*/
#define INTEGER_BIT_SHIFT (60)
/**
* @brief return `true` if arg is `nil`, else `false`.
*
* Note that this doesn't really belong in `peano.h`, but after code cleanup it
* was the last thing remaining in either `boolean.c` or `boolean.h`, and it
* wasn't worth keeping two files around for one one-line macro.
*
* @param arg
* @return true if the sole argument is `nil`.
* @return false otherwise.
*/
#define truthy(arg)(!nilp(arg))
bool zerop( struct cons_pointer arg );
struct cons_pointer negative( struct cons_pointer arg );
bool is_negative( struct cons_pointer arg );
struct cons_pointer absolute( struct cons_pointer arg );
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer lisp_absolute( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env );
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_is_negative( struct stack_frame
*frame,
struct cons_pointer frame_pointer, struct
cons_pointer env );
struct cons_pointer
lisp_multiply( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer negative( struct cons_pointer arg );
struct cons_pointer subtract_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer
lisp_subtract( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env );
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 );
#endif /* PEANO_H */

411
archive/c/arith/ratio.c Normal file
View file

@ -0,0 +1,411 @@
/*
* ratio.c
*
* functions for rational number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <math.h>
#include <stdio.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
#include "arith/real.h"
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/stack.h"
#include "ops/equal.h"
#include "ops/lispops.h"
/**
* @brief return, as an int64_t, the greatest common divisor of `m` and `n`,
*/
int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o;
while ( m ) {
o = m;
m = n % m;
n = o;
}
return o;
}
/**
* @brief return, as an int64_t, the least common multiple of `m` and `n`,
*/
int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n;
}
struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
struct cons_pointer result = pointer;
if ( ratiop( pointer ) ) {
struct cons_space_object cell = pointer2cell( pointer );
struct cons_space_object dividend =
pointer2cell( cell.payload.ratio.dividend );
struct cons_space_object divisor =
pointer2cell( cell.payload.ratio.divisor );
if ( divisor.payload.integer.value == 1 ) {
result = pointer2cell( pointer ).payload.ratio.dividend;
} else {
int64_t ddrv = dividend.payload.integer.value,
drrv = divisor.payload.integer.value,
gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
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 ),
false );
}
}
}
}
// TODO: else throw exception?
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
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 );
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, true );
} else {
r = throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
NIL );
}
debug_print( L"add_ratio_ratio => ", DEBUG_ARITH );
debug_print_object( r, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return r;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
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 );
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false );
result = add_ratio_ratio( ratio, ratarg );
release_integer( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ), NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
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`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
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 );
// 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, false ),
result = multiply_ratio_ratio( arg1, i );
dec_ref( i );
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer multiply_ratio_ratio( struct
cons_pointer arg1, struct
cons_pointer arg2 ) {
// TODO: this now has to work if arg1 is an integer
struct cons_pointer result;
debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t 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 dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL );
result = make_ratio( dividend, divisor, true );
release_integer( dividend );
release_integer( divisor );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
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`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
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 );
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false );
result = multiply_ratio_ratio( ratio, ratarg );
release_integer( one );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the difference of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
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 );
struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i );
dec_ref( i );
return result;
}
/**
* Construct a ratio frame from this `dividend` and `divisor`, expected to
* be integers, in the context of the stack_frame indicated by this
* `frame_pointer`.
* @exception if either `dividend` or `divisor` is not an integer.
*/
struct cons_pointer make_ratio( struct cons_pointer dividend,
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 );
inc_ref( divisor );
struct cons_pointer unsimplified = allocate_cell( RATIOTV );
struct cons_space_object *cell = &pointer2cell( unsimplified );
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
if ( simplify ) {
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
}
} else {
result = unsimplified;
}
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
NIL );
}
debug_print( L" => ", DEBUG_ALLOC );
debug_print_object( result, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC );
return result;
}
/**
* True if a and be are identical rationals, else false.
*
* TODO: we need ways of checking whether rationals are equal
* to floats and to integers.
*/
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( ratiop( a ) && ratiop( b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
result = equal_integer_integer( cell_a->payload.ratio.dividend,
cell_b->payload.ratio.dividend ) &&
equal_integer_integer( cell_a->payload.ratio.divisor,
cell_b->payload.ratio.divisor );
}
return result;
}
/**
* @brief convert a ratio to an equivalent long double.
*
* @param rat a pointer to a ratio.
* @return long double
*/
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 );
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_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 );;
} else {
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;
}

41
archive/c/arith/ratio.h Normal file
View file

@ -0,0 +1,41 @@
/**
* ratio.h
*
* functions for rational number cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* 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 cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct
cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
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, bool simplify );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
long double c_ratio_to_ld( struct cons_pointer rat );
#endif

29
archive/c/arith/real.c Normal file
View file

@ -0,0 +1,29 @@
/*
* real.c
*
* functions for real number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "debug.h"
#include "io/read.h"
/**
* 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.
*/
struct cons_pointer make_real( long double value ) {
struct cons_pointer result = allocate_cell( REALTV );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value;
debug_dump_object( result, DEBUG_ARITH );
return result;
}

32
archive/c/arith/real.h Normal file
View file

@ -0,0 +1,32 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
/*
* File: real.h
* Author: simon
*
* Created on 14 August 2017, 17:25
*/
#ifndef REAL_H
#define REAL_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* 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.
*/
struct cons_pointer make_real( long double value );
#ifdef __cplusplus
}
#endif
#endif /* REAL_H */