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

Work on exception handling, especially around ratio arithmetic

Browse source 
Much simplified but will break things!
This commit is contained in:
Simon Brooke 2021-07-25 17:02:28 +01:00
parent d2101dbd47
commit 70d176982b
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
14 changed files with 298 additions and 258 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -38,3 +38,5 @@ utils_src/readprintwc/out
src/io/fopen
hi\.*
.vscode/

5
lisp/defun.lisp
View file

@ -9,6 +9,11 @@
(set (car form) (apply 'lambda (cdr form))))
(t nil))))
(set! defun!
(nlambda
form
(eval (list 'set! (car form) (cons 'lambda (cdr form))))))
(defun! square (x) (* x x))
(set! defsp!

35
src/arith/integer.c
View file

@ -390,3 +390,38 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
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;
}
/**
* true if `a` is an integer, and `b` is a real number whose value is the
* value of that integer.
*/
bool equal_integer_real(struct cons_pointer a, struct cons_pointer b) {
bool result = false;
if (integerp(a) && realp(b))
{
long double bv = pointer2cell(b).payload.real.value;
if (floor(bv) == bv) {
result = pointer2cell(a).payload.integer.value == (int64_t)bv;
}
}
return result;
}

18
src/arith/integer.h
View file

@ -11,15 +11,19 @@
#ifndef __integer_h
#define __integer_h
struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer make_integer(int64_t value, struct cons_pointer more);
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b );
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 multiply_integers(struct cons_pointer a,
struct cons_pointer b);
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base );
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

54
src/arith/peano.c
View file

@ -86,8 +86,7 @@ bool is_negative( struct cons_pointer arg ) {
return result;
}
struct cons_pointer absolute( struct cons_pointer frame_pointer,
struct cons_pointer arg ) {
struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
@ -99,9 +98,7 @@ struct cons_pointer absolute( struct cons_pointer frame_pointer,
cell.payload.integer.more );
break;
case RATIOTV:
result = make_ratio( frame_pointer,
absolute( frame_pointer,
cell.payload.ratio.dividend ),
result = make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor );
break;
case REALTV:
@ -210,7 +207,7 @@ 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 ) {
return absolute( frame_pointer, frame->arg[0] );
return absolute( frame->arg[0] );
}
/**
@ -251,7 +248,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break;
case RATIOTV:
result =
add_integer_ratio( frame_pointer, arg1, arg2 );
add_integer_ratio( arg1, arg2 );
break;
case REALTV:
result =
@ -272,10 +269,10 @@ struct cons_pointer add_2( struct stack_frame *frame,
break;
case INTEGERTV:
result =
add_integer_ratio( frame_pointer, arg2, arg1 );
add_integer_ratio( arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 );
result = add_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
@ -384,7 +381,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
case RATIOTV:
result =
multiply_integer_ratio( frame_pointer, arg1,
multiply_integer_ratio( arg1,
arg2 );
break;
case REALTV:
@ -409,12 +406,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
case INTEGERTV:
result =
multiply_integer_ratio( frame_pointer, arg2,
multiply_integer_ratio( arg2,
arg1 );
break;
case RATIOTV:
result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
multiply_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
@ -496,8 +493,7 @@ struct cons_pointer lisp_multiply( struct
* return a cons_pointer indicating a number which is the
* 0 - the number indicated by `arg`.
*/
struct cons_pointer negative( struct cons_pointer frame,
struct cons_pointer arg ) {
struct cons_pointer negative( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
@ -514,9 +510,7 @@ struct cons_pointer negative( struct cons_pointer frame,
result = TRUE;
break;
case RATIOTV:
result = make_ratio( frame,
negative( frame,
cell.payload.ratio.dividend ),
result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor );
break;
case REALTV:
@ -571,7 +565,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
break;
case INTEGERTV:{
struct cons_pointer i =
negative( frame_pointer, arg2 );
negative( arg2 );
inc_ref( i );
result = add_integers( arg1, i );
dec_ref( i );
@ -579,11 +573,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
break;
case RATIOTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, arg1,
make_ratio( arg1,
make_integer( 1, NIL ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, tmp, arg2 );
subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
}
break;
@ -606,16 +600,16 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
break;
case INTEGERTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, arg2,
make_ratio( arg2,
make_integer( 1, NIL ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, arg1, tmp );
subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result = subtract_ratio_ratio( frame_pointer, arg1, arg2 );
result = subtract_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
@ -687,11 +681,11 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
make_ratio( frame_pointer, frame->arg[0],
make_ratio( frame->arg[0],
frame->arg[1] );
/* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified );
result = simplify_ratio( unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
@ -700,10 +694,10 @@ struct cons_pointer lisp_divide( struct
case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one );
make_ratio( frame->arg[0], one );
inc_ref( ratio );
result =
divide_ratio_ratio( frame_pointer, ratio,
divide_ratio_ratio( ratio,
frame->arg[1] );
dec_ref( ratio );
}
@ -729,10 +723,10 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer one = make_integer( 1, NIL );
inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[1], one );
make_ratio( frame->arg[1], one );
inc_ref( ratio );
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
divide_ratio_ratio( frame->arg[0],
ratio );
dec_ref( ratio );
dec_ref( one );
@ -740,7 +734,7 @@ struct cons_pointer lisp_divide( struct
break;
case RATIOTV:
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
divide_ratio_ratio( frame->arg[0],
frame->arg[1] );
break;
case REALTV:

9
src/arith/peano.h
View file

@ -19,13 +19,11 @@
bool zerop( struct cons_pointer arg );
struct cons_pointer negative( struct cons_pointer frame,
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 frame_pointer,
struct cons_pointer arg );
struct cons_pointer absolute( struct cons_pointer arg );
long double to_long_double( struct cons_pointer arg );
@ -46,8 +44,7 @@ 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 frame,
struct cons_pointer arg );
struct cons_pointer negative( struct cons_pointer arg );
struct cons_pointer subtract_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,

143
src/arith/ratio.c
View file

@ -43,42 +43,43 @@ int64_t least_common_multiple( int64_t m, int64_t 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.
* @exception If `arg` isn't a ratio, will return an exception.
*/
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) {
struct cons_pointer result = arg;
struct cons_pointer simplify_ratio( struct cons_pointer pointer) {
struct cons_pointer result = 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 ( ratiop( arg ) ) {
int64_t 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 (divisor.payload.integer.value == 1)
{
result = pointer2cell(pointer).payload.ratio.dividend;
}
else
{
if (ratiop(pointer))
{
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 = make_integer( ddrv / gcd, NIL );
} else {
result =
make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ),
make_integer( drrv / gcd, NIL ) );
if (gcd > 1)
{
if (drrv / gcd == 1)
{
result = make_integer(ddrv / gcd, NIL);
}
else
{
result =
make_ratio(make_integer(ddrv / gcd, NIL),
make_integer(drrv / gcd, NIL));
}
}
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
}
return result;
}
}
/**
@ -87,8 +88,7 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer r, result;
@ -116,18 +116,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
m1, m2 );
if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v, NIL ),
r = make_ratio( make_integer( dd1v + dd2v, NIL ),
cell1.payload.ratio.divisor );
} else {
struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ),
dr1vm = make_integer( dr1v * m1, NIL ),
dd2vm = make_integer( dd2v * m2, NIL ),
dr2vm = make_integer( dr2v * m2, NIL ),
r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r1 = make_ratio( dd1vm, dr1vm ),
r2 = make_ratio( dd2vm, dr2vm );
r = add_ratio_ratio( frame_pointer, r1, r2 );
r = add_ratio_ratio( r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
@ -136,7 +135,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
dec_ref( r2 );
}
result = simplify_ratio( frame_pointer, r );
result = simplify_ratio( r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
@ -146,7 +145,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
NIL );
}
debug_print( L" => ", DEBUG_ARITH );
@ -163,16 +162,16 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
* `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: not longer works
struct cons_pointer one = make_integer( 1, NIL ),
ratio = make_ratio( frame_pointer, intarg, one );
ratio = make_ratio( intarg, one );
result = add_ratio_ratio( frame_pointer, ratio, ratarg );
result = add_ratio_ratio( ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
@ -183,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ),
frame_pointer );
NIL );
}
return result;
@ -195,15 +194,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.
// 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 ), result =
multiply_ratio_ratio( frame_pointer, arg1, i );
multiply_ratio_ratio( arg1, i );
dec_ref( i );
@ -216,9 +214,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
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 );
@ -241,9 +240,9 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
make_ratio( frame_pointer, make_integer( ddrv, NIL ),
make_ratio( make_integer( ddrv, NIL ),
make_integer( drrv, NIL ) );
result = simplify_ratio( frame_pointer, unsimplified );
result = simplify_ratio( unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
@ -252,7 +251,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
NIL );
}
return result;
@ -264,15 +263,15 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
* `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: no longer works; fix
struct cons_pointer one = make_integer( 1, NIL ),
ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
ratio = make_ratio( intarg, one );
result = multiply_ratio_ratio( ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
@ -280,7 +279,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
NIL );
}
return result;
@ -293,11 +292,10 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = negative( frame_pointer, arg2 ),
result = add_ratio_ratio( frame_pointer, arg1, i );
struct cons_pointer i = negative( arg2),
result = add_ratio_ratio( arg1, i );
dec_ref( i );
@ -311,8 +309,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
* `frame_pointer`.
* @exception if either `dividend` or `divisor` is not an integer.
*/
struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend,
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor ) {
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
@ -326,10 +323,30 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
result =
throw_exception( c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
frame_pointer );
NIL );
}
debug_dump_object( result, DEBUG_ARITH );
return result;
}
/**
* True if a and be are identical ratios, else false.
*/
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;
}

25
src/arith/ratio.h
View file

@ -11,36 +11,29 @@
#ifndef __ratio_h
#define __ratio_h
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg );
struct cons_pointer simplify_ratio( struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct
cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend,
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor );
bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b);
#endif

6
src/io/read.c
View file

@ -250,7 +250,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( seen_period ) {
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
struct cons_pointer div = make_ratio( frame_pointer, result,
struct cons_pointer div = make_ratio( result,
make_integer( powl
( to_long_double
( base ),
@ -263,14 +263,14 @@ struct cons_pointer read_number( struct stack_frame *frame,
dec_ref( div );
} else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
result = make_ratio( frame_pointer, dividend, result );
result = make_ratio( dividend, result );
}
if ( neg ) {
debug_print( L"read_number: converting result to negative\n",
DEBUG_IO );
result = negative( frame_pointer, result );
result = negative( result );
}
debug_print( L"read_number returning\n", DEBUG_IO );

4
src/memory/consspaceobject.h
View file

@ -346,7 +346,7 @@
* true if `conspoint` points to some sort of a number cell,
* else false
*/
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG))
/**
* true if `conspoint` points to a sequence (list, string or, later, vector),
@ -614,7 +614,7 @@ struct cons_space_object {
*/
struct cons_payload cons;
/**
* if tag == EXCEPTIONTAG
* if tag == EXCEPTIONTAG || tag == LOOPXTAG
*/
struct exception_payload exception;
/**

1
src/memory/stack.c
View file

@ -267,7 +267,6 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) {
void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
// todo: if the payload isn't a message, we maybe shouldn't print it?
print( output, pointer2cell( pointer ).payload.exception.payload );
url_fputws( L"\n", output );
dump_stack_trace( output,

154
src/ops/equal.c
View file

@ -12,14 +12,17 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "peano.h"
#include "ratio.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 ) );
bool eq(struct cons_pointer a, struct cons_pointer b)
{
return ((a.page == b.page) && (a.offset == b.offset));
}
/**
@ -29,12 +32,12 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
* @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 );
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;
}
/**
@ -42,82 +45,99 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) {
* @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';
bool end_of_string(struct cons_pointer string)
{
return nilp(string) ||
pointer2cell(string).payload.string.character == '\0';
}
/**
* 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 ) {
bool result = eq( a, b );
bool equal(struct cons_pointer a, struct cons_pointer b)
{
bool result = eq(a, b);
if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if (!result && 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:
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:
/*
switch (cell_a->tag.value)
{
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
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.
*/
result =
cell_a->payload.string.character ==
cell_b->payload.string.character
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
break;
case INTEGERTV:
result =
( cell_a->payload.integer.value ==
cell_b->payload.integer.value ) &&
equal( cell_a->payload.integer.more,
cell_b->payload.integer.more );
break;
case REALTV:
{
double num_a = to_long_double( a );
double num_b = to_long_double( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
result =
cell_a->payload.string.character ==
cell_b->payload.string.character &&
(equal(cell_a->payload.string.cdr,
cell_b->payload.string.cdr) ||
(end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr)));
break;
case INTEGERTV:
result =
(cell_a->payload.integer.value ==
cell_b->payload.integer.value) &&
equal(cell_a->payload.integer.more,
cell_b->payload.integer.more);
break;
case RATIOTV:
result = equal_ratio_ratio(a, b);
break;
case REALTV:
{
double num_a = to_long_double(a);
double num_b = to_long_double(b);
double max =
fabs(num_a) >
fabs(num_b)
? fabs(num_a)
: fabs(num_b);
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
/*
* not more different than one part in a million - close enough
*/
result = fabs(num_a - num_b) < (max / 1000000.0);
}
break;
default:
result = false;
break;
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
}
else if (numberp(a) && numberp(b))
{
if (integerp(a))
{
result = equal_integer_real(a, b);
}
else if (integerp(b))
{
result = equal_integer_real(b, a);
}
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
return result;
}

62
src/ops/exceptions.c
View file

@ -1,62 +0,0 @@
/*
* exceptions.c
*
* This is really, really unfinished and doesn't yet work. One of the really key
* things about exceptions is that the stack frames between the throw and the
* catch should not be derefed, so eval/apply will need to be substantially
* re-written.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "map.h"
#include "print.h"
#include "read.h"
#include "stack.h"
#include "vectorspace.h"
/**
* OK, the idea here (and I know this is less than perfect) is that the basic `try`
* function in PSSE takes two arguments, the first, `body`, being a list of forms,
* and the second, `catch`, being a catch handler (which is also a list of forms).
* Forms from `body` are evaluated in turn until one returns an exception object,
* or until the list is exhausted. If the list was exhausted, then the value of
* evaluating the last form in `body` is returned. If an exception was encountered,
* then each of the forms in `catch` is evaluated and the value of the last of
* those is returned.
*
* This is experimental. It almost certainly WILL change.
*/
struct cons_pointer lisp_try(struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env)
{
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env);
if (loopexitp(result))
{
// TODO: need to put the exception into the environment!
result = c_progn(frame, frame_pointer, frame->arg[1], env);
}
return result;
}

36
src/ops/lispops.c
View file

@ -110,6 +110,37 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
return c_reverse( result);
}
/**
* OK, the idea here (and I know this is less than perfect) is that the basic `try`
* function in PSSE takes two arguments, the first, `body`, being a list of forms,
* and the second, `catch`, being a catch handler (which is also a list of forms).
* Forms from `body` are evaluated in turn until one returns an exception object,
* or until the list is exhausted. If the list was exhausted, then the value of
* evaluating the last form in `body` is returned. If an exception was encountered,
* then each of the forms in `catch` is evaluated and the value of the last of
* those is returned.
*
* This is experimental. It almost certainly WILL change.
*/
struct cons_pointer lisp_try(struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env) {
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env);
if (exceptionp(result))
{
// TODO: need to put the exception into the environment!
result = c_progn(frame, frame_pointer, frame->arg[1],
make_cons(
make_cons(c_string_to_lisp_keyword(L"*exception*"),
result),
env));
}
return result;
}
/**
* Return the object list (root namespace).
*
@ -251,6 +282,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
dec_ref( result );
result = eval_form( frame, frame_pointer, sexpr, new_env );
if (exceptionp(result))
{
break;
}
}
dec_ref( new_env );