From 70d176982b04709abd94a1b5e861e8c7b596a95b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 25 Jul 2021 17:02:28 +0100 Subject: [PATCH] Work on exception handling, especially around ratio arithmetic Much simplified but will break things! --- .gitignore | 2 + lisp/defun.lisp | 5 ++ src/arith/integer.c | 35 ++++++++ src/arith/integer.h | 18 ++-- src/arith/peano.c | 54 ++++++------ src/arith/peano.h | 9 +- src/arith/ratio.c | 145 ++++++++++++++++++--------------- src/arith/ratio.h | 25 ++---- src/io/read.c | 6 +- src/memory/consspaceobject.h | 4 +- src/memory/stack.c | 1 - src/ops/equal.c | 154 ++++++++++++++++++++--------------- src/ops/exceptions.c | 62 -------------- src/ops/lispops.c | 36 ++++++++ 14 files changed, 298 insertions(+), 258 deletions(-) delete mode 100644 src/ops/exceptions.c diff --git a/.gitignore b/.gitignore index 1968658..3bf3906 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,5 @@ utils_src/readprintwc/out src/io/fopen hi\.* + +.vscode/ diff --git a/lisp/defun.lisp b/lisp/defun.lisp index cec893b..a6d80f5 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -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! diff --git a/src/arith/integer.c b/src/arith/integer.c index 1b2667c..e02d30e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -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; +} \ No newline at end of file diff --git a/src/arith/integer.h b/src/arith/integer.h index 117a0bf..f0117f5 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -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 diff --git a/src/arith/peano.c b/src/arith/peano.c index 8e4cb43..8fe63fb 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -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: diff --git a/src/arith/peano.h b/src/arith/peano.h index 7ad7662..89bfc3d 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -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, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 65b09da..8976e38 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -43,52 +43,52 @@ 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; + } - /** * 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 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; +} \ No newline at end of file diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 5a3b0d6..d440530 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -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 diff --git a/src/io/read.c b/src/io/read.c index 4f3ed0a..0f32815 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -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 ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 4b0500b..f82b103 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -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; /** diff --git a/src/memory/stack.c b/src/memory/stack.c index d6d3c36..e26bd0e 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -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, diff --git a/src/ops/equal.c b/src/ops/equal.c index c4d7f54..6a87de8 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -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; } diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c deleted file mode 100644 index 48c031f..0000000 --- a/src/ops/exceptions.c +++ /dev/null @@ -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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - -#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; -} - - diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 8dd0109..c96b1be 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -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 );