Upversioned the C source tree to '0.0.7-SNAPSHOT', but proposing to start experimental
work towards 0.1.0 in separate source trees.
This commit is contained in:
parent
788cb48b37
commit
99d4794f3b
57 changed files with 2 additions and 2 deletions
433
src/ops/equal.c
433
src/ops/equal.c
|
|
@ -1,433 +0,0 @@
|
|||
/*
|
||||
* equal.c
|
||||
*
|
||||
* Checks for shallow and deep equality
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <math.h>
|
||||
#include <stdbool.h>
|
||||
#include <string.h>
|
||||
|
||||
#include "arith/integer.h"
|
||||
#include "arith/peano.h"
|
||||
#include "arith/ratio.h"
|
||||
#include "debug.h"
|
||||
#include "memory/conspage.h"
|
||||
#include "memory/consspaceobject.h"
|
||||
#include "memory/vectorspace.h"
|
||||
#include "ops/equal.h"
|
||||
#include "ops/intern.h"
|
||||
|
||||
/**
|
||||
* Shallow, and thus cheap, equality: true if these two objects are
|
||||
* the same object, else false.
|
||||
*/
|
||||
bool eq( struct cons_pointer a, struct cons_pointer b ) {
|
||||
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
|
||||
}
|
||||
|
||||
/**
|
||||
* True if the objects at these two cons pointers have the same tag, else false.
|
||||
* @param a a pointer to a cons-space object;
|
||||
* @param b another pointer to a cons-space object.
|
||||
* @return true if the objects at these two cons pointers have the same tag,
|
||||
* else false.
|
||||
*/
|
||||
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
return cell_a->tag.value == cell_b->tag.value;
|
||||
}
|
||||
|
||||
/**
|
||||
* Some strings will be null terminated and some will be NIL terminated... ooops!
|
||||
* @param string the string to test
|
||||
* @return true if it's the end of a string.
|
||||
*/
|
||||
bool end_of_string( struct cons_pointer string ) {
|
||||
return nilp( string ) ||
|
||||
pointer2cell( string ).payload.string.character == '\0';
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief compare two long doubles and returns true if they are the same to
|
||||
* within a tolerance of one part in a billion.
|
||||
*
|
||||
* @param a
|
||||
* @param b
|
||||
* @return true if `a` and `b` are equal to within one part in a billion.
|
||||
* @return false otherwise.
|
||||
*/
|
||||
bool equal_ld_ld( long double a, long double b ) {
|
||||
long double fa = fabsl( a );
|
||||
long double fb = fabsl( b );
|
||||
/* difference of magnitudes */
|
||||
long double diff = fabsl( fa - fb );
|
||||
/* average magnitude of the two */
|
||||
long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
|
||||
/* amount of difference we will tolerate for equality */
|
||||
long double tolerance = av * 0.000000001;
|
||||
|
||||
bool result = ( fabsl( a - b ) < tolerance );
|
||||
|
||||
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief Private function, don't use. It depends on its arguments being
|
||||
* numbers and doesn't sanity check them.
|
||||
*
|
||||
* @param a a lisp integer -- if it isn't an integer, things will break.
|
||||
* @param b a lisp real -- if it isn't a real, things will break.
|
||||
* @return true if the two numbers have equal value.
|
||||
* @return false if they don't.
|
||||
*/
|
||||
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
|
||||
debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
|
||||
debug_print_object( a, DEBUG_ARITH );
|
||||
debug_print( L" = ", DEBUG_ARITH );
|
||||
debug_print_object( b, DEBUG_ARITH );
|
||||
bool result = false;
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
if ( nilp( cell_a->payload.integer.more ) ) {
|
||||
result =
|
||||
equal_ld_ld( ( long double ) cell_a->payload.integer.value,
|
||||
cell_b->payload.real.value );
|
||||
} else {
|
||||
fwprintf( stderr,
|
||||
L"\nequality is not yet implemented for bignums compared to reals." );
|
||||
}
|
||||
|
||||
debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
|
||||
result );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief Private function, don't use. It depends on its arguments being
|
||||
* numbers and doesn't sanity check them.
|
||||
*
|
||||
* @param a a lisp integer -- if it isn't an integer, things will break.
|
||||
* @param b a lisp number.
|
||||
* @return true if the two numbers have equal value.
|
||||
* @return false if they don't.
|
||||
*/
|
||||
bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
|
||||
debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
|
||||
debug_print_object( a, DEBUG_ARITH );
|
||||
debug_print( L" = ", DEBUG_ARITH );
|
||||
debug_print_object( b, DEBUG_ARITH );
|
||||
bool result = false;
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
switch ( cell_b->tag.value ) {
|
||||
case INTEGERTV:
|
||||
result = equal_integer_integer( a, b );
|
||||
break;
|
||||
case REALTV:
|
||||
result = equal_integer_real( a, b );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
|
||||
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
|
||||
result );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief Private function, don't use. It depends on its arguments being
|
||||
* numbers and doesn't sanity check them.
|
||||
*
|
||||
* @param a a lisp real -- if it isn't an real, things will break.
|
||||
* @param b a lisp number.
|
||||
* @return true if the two numbers have equal value.
|
||||
* @return false if they don't.
|
||||
*/
|
||||
bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
|
||||
debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
|
||||
debug_print_object( a, DEBUG_ARITH );
|
||||
debug_print( L" = ", DEBUG_ARITH );
|
||||
debug_print_object( b, DEBUG_ARITH );
|
||||
bool result = false;
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
switch ( cell_b->tag.value ) {
|
||||
case INTEGERTV:
|
||||
result = equal_integer_real( b, a );
|
||||
break;
|
||||
case REALTV:{
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
result =
|
||||
equal_ld_ld( cell_a->payload.real.value,
|
||||
cell_b->payload.real.value );
|
||||
}
|
||||
break;
|
||||
case RATIOTV:
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
result =
|
||||
equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
|
||||
break;
|
||||
}
|
||||
|
||||
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief Private function, don't use. It depends on its arguments being
|
||||
* numbers and doesn't sanity check them.
|
||||
*
|
||||
* @param a a number
|
||||
* @param b a number
|
||||
* @return true if the two numbers have equal value.
|
||||
* @return false if they don't.
|
||||
*/
|
||||
bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result = eq( a, b );
|
||||
|
||||
debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
|
||||
debug_print_object( a, DEBUG_ARITH );
|
||||
debug_print( L" = ", DEBUG_ARITH );
|
||||
debug_print_object( b, DEBUG_ARITH );
|
||||
|
||||
if ( !result ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
switch ( cell_a->tag.value ) {
|
||||
case INTEGERTV:
|
||||
result = equal_integer_number( a, b );
|
||||
break;
|
||||
case REALTV:
|
||||
result = equal_real_number( a, b );
|
||||
break;
|
||||
case RATIOTV:
|
||||
switch ( cell_b->tag.value ) {
|
||||
case INTEGERTV:
|
||||
/* as ratios are simplified by make_ratio, any
|
||||
* ratio that would simplify to an integer is an
|
||||
* integer, TODO: no longer always true. */
|
||||
result = false;
|
||||
break;
|
||||
case REALTV:
|
||||
result = equal_real_number( b, a );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = equal_ratio_ratio( a, b );
|
||||
break;
|
||||
/* can't throw an exception from here, but non-numbers
|
||||
* shouldn't have been passed in anyway, so no default. */
|
||||
}
|
||||
break;
|
||||
/* can't throw an exception from here, but non-numbers
|
||||
* shouldn't have been passed in anyway, so no default. */
|
||||
}
|
||||
}
|
||||
|
||||
debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
|
||||
result );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief equality of two map-like things.
|
||||
*
|
||||
* The list returned by `keys` on a map-like thing is not sorted, and is not
|
||||
* guaranteed always to come out in the same order. So equality is established
|
||||
* if:
|
||||
* 1. the length of the keys list is the same; and
|
||||
* 2. the value of each key in the keys list for map `a` is the same in map `a`
|
||||
* and in map `b`.
|
||||
*
|
||||
* Private function, do not use outside this file, **WILL NOT** work
|
||||
* unless both arguments are VECPs.
|
||||
*
|
||||
* @param a a pointer to a vector space object.
|
||||
* @param b another pointer to a vector space object.
|
||||
* @return true if the two objects have the same logical structure.
|
||||
* @return false otherwise.
|
||||
*/
|
||||
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result = false;
|
||||
|
||||
struct cons_pointer keys_a = hashmap_keys( a );
|
||||
|
||||
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
|
||||
result = true;
|
||||
|
||||
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
||||
struct cons_pointer key = c_car( i );
|
||||
if ( !equal
|
||||
( hashmap_get( a, key, false ),
|
||||
hashmap_get( b, key, false ) ) ) {
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief equality of two vector-space things.
|
||||
*
|
||||
* Expensive, but we need to be able to check for equality of at least hashmaps
|
||||
* and namespaces.
|
||||
*
|
||||
* Private function, do not use outside this file, not guaranteed to work
|
||||
* unless both arguments are VECPs pointing to map like things.
|
||||
*
|
||||
* @param a a pointer to a vector space object.
|
||||
* @param b another pointer to a vector space object.
|
||||
* @return true if the two objects have the same logical structure.
|
||||
* @return false otherwise.
|
||||
*/
|
||||
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result = false;
|
||||
|
||||
if ( eq( a, b ) ) {
|
||||
result = true; // same
|
||||
/* there shouldn't ever be two separate VECP cells which point to the
|
||||
* same address in vector space, so I don't believe it's worth checking
|
||||
* for this.
|
||||
*/
|
||||
} else if ( vectorp( a ) && vectorp( b ) ) {
|
||||
struct vector_space_object *va = pointer_to_vso( a );
|
||||
struct vector_space_object *vb = pointer_to_vso( b );
|
||||
|
||||
/* what we're saying here is that a namespace is not equal to a map,
|
||||
* even if they have identical logical structure. Is this right? */
|
||||
if ( va->header.tag.value == vb->header.tag.value ) {
|
||||
switch ( va->header.tag.value ) {
|
||||
case HASHTV:
|
||||
case NAMESPACETV:
|
||||
result = equal_map_map( a, b );
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
// else can't throw an exception from here but TODO: should log.
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* Deep, and thus expensive, equality: true if these two objects have
|
||||
* identical structure, else false.
|
||||
*/
|
||||
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||
debug_print( L"\nequal: ", DEBUG_EQUAL );
|
||||
debug_print_object( a, DEBUG_EQUAL );
|
||||
debug_print( L" = ", DEBUG_EQUAL );
|
||||
debug_print_object( b, DEBUG_EQUAL );
|
||||
|
||||
bool result = false;
|
||||
|
||||
if ( eq( a, b ) ) {
|
||||
result = true;
|
||||
} else if ( !numberp( a ) && same_type( a, b ) ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
switch ( cell_a->tag.value ) {
|
||||
case CONSTV:
|
||||
case LAMBDATV:
|
||||
case NLAMBDATV:
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
result =
|
||||
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
|
||||
&& equal( cell_a->payload.cons.cdr,
|
||||
cell_b->payload.cons.cdr );
|
||||
break;
|
||||
case KEYTV:
|
||||
case STRINGTV:
|
||||
case SYMBOLTV:
|
||||
/* slightly complex because a string may or may not have a '\0'
|
||||
* cell at the end, but I'll ignore that for now. I think in
|
||||
* practice only the empty string will.
|
||||
*/
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
if ( cell_a->payload.string.hash ==
|
||||
cell_b->payload.string.hash ) {
|
||||
wchar_t a_buff[STRING_SHIPYARD_SIZE],
|
||||
b_buff[STRING_SHIPYARD_SIZE];
|
||||
uint32_t tag = cell_a->tag.value;
|
||||
int i = 0;
|
||||
|
||||
memset( a_buff, 0, sizeof( a_buff ) );
|
||||
memset( b_buff, 0, sizeof( b_buff ) );
|
||||
|
||||
for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
|
||||
&& !nilp( b ); i++ ) {
|
||||
a_buff[i] = cell_a->payload.string.character;
|
||||
a = c_cdr( a );
|
||||
cell_a = &pointer2cell( a );
|
||||
|
||||
b_buff[i] = cell_b->payload.string.character;
|
||||
b = c_cdr( b );
|
||||
cell_b = &pointer2cell( b );
|
||||
}
|
||||
|
||||
#ifdef DEBUG
|
||||
debug_print( L"Comparing '", DEBUG_EQUAL );
|
||||
debug_print( a_buff, DEBUG_EQUAL );
|
||||
debug_print( L"' to '", DEBUG_EQUAL );
|
||||
debug_print( b_buff, DEBUG_EQUAL );
|
||||
debug_print( L"'\n", DEBUG_EQUAL );
|
||||
#endif
|
||||
|
||||
/* OK, now we have wchar string buffers loaded from the objects. We
|
||||
* may not have exhausted either string, so the buffers being equal
|
||||
* isn't sufficient. So we recurse at least once. */
|
||||
|
||||
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
|
||||
&& equal( c_cdr( a ), c_cdr( b ) );
|
||||
}
|
||||
break;
|
||||
case VECTORPOINTTV:
|
||||
if ( cell_b->tag.value == VECTORPOINTTV ) {
|
||||
result = equal_vector_vector( a, b );
|
||||
} else {
|
||||
result = false;
|
||||
}
|
||||
break;
|
||||
default:
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
} else if ( numberp( a ) && numberp( b ) ) {
|
||||
result = equal_number_number( a, b );
|
||||
}
|
||||
|
||||
/*
|
||||
* there's only supposed ever to be one T and one NIL cell, so each
|
||||
* should be caught by eq.
|
||||
*
|
||||
* I'm not certain what equality means for read and write streams, so
|
||||
* I'll ignore them, too, for now.
|
||||
*/
|
||||
|
||||
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
|
||||
|
||||
return result;
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue