diff --git a/src/arith/integer.c b/src/arith/integer.c index 9b23001..779a112 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -94,145 +94,110 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { return result; } -/** - * Return 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 ) { - debug_print( L"Entering add_integers\n", DEBUG_ARITH ); +/** + * internal workings of both `add_integers` and `multiply_integers` (and + * possibly, later, other operations. Apply the operator `op` to the + * integer arguments `a` and `b`, and return a pointer to the result. If + * either `a` or `b` is not an integer, returns `NIL`. + */ +struct cons_pointer operate_on_integers( struct cons_pointer a, + struct cons_pointer b, + char op) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"add_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" + ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); + debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); + debug_dump_object( a, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L" %c \n", op); + debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = ( __int128_t ) integerp( a ) ? pointer2cell( a ). - payload.integer.value : 0; + payload.integer.value : op == '*' ? 1 : 0; __int128_t bv = ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : 0; + payload.integer.value : op == '*' ? 1 : 0; - __int128_t rv = av + bv + carry; + /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and + * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry + * is very large (which I'm not certain whether it can be and am not + * intellectually up to proving it this morning) adding the carry might + * overflow `__int128_t`. Edge-case testing required. + */ + __int128_t rv = NAN; + + switch (op) { + case '*': + rv = ( av * bv ) + carry; + break; + case '+': + rv = av + bv + carry; + break; + } if ( MAX_INTEGER >= rv ) { - carry = 0; + carry = 0; } else { - // TODO: we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"add_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv = rv & MAX_INTEGER; + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. + carry = rv >> 60; + debug_printf( DEBUG_ARITH, + L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + rv &= MAX_INTEGER; } struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); if ( nilp( cursor ) ) { - cursor = tail; + cursor = tail; } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; + cursor = tail; } if ( nilp( result ) ) { - result = cursor; + result = cursor; } a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } } - debug_print( L"add_integers returning: ", DEBUG_ARITH ); + + debug_print( L"operate_on_integers returning:\n", DEBUG_ARITH ); debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; } +/** + * Return 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 ) { + + return operate_on_integers(a, b, '+'); +} + /** * Return the product of the integers pointed to by `a` and `b`. If either isn't * an integer, will return nil. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - struct cons_pointer result = NIL; - struct cons_pointer cursor = NIL; - __int128_t carry = 0; - - if ( integerp( a ) && integerp( b ) ) { - debug_print( L"multiply_integers: \n", DEBUG_ARITH ); - debug_dump_object( a, DEBUG_ARITH ); - debug_print( L" x \n", DEBUG_ARITH ); - debug_dump_object( b, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = - ( __int128_t ) integerp( a ) ? pointer2cell( a ). - payload.integer.value : 1; - __int128_t bv = - ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : 1; - - /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and - * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry - * is very large (which I'm not certain whether it can be and am not - * intellectually up to proving it this morning) adding the carry might - * overflow `__int128_t`. Edge-case testing required. - */ - __int128_t rv = ( av * bv ) + carry; - - if ( MAX_INTEGER >= rv ) { - carry = 0; - } else { - // TODO: we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv &= MAX_INTEGER; - } - - struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - - if ( nilp( cursor ) ) { - cursor = tail; - } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; - } - - if ( nilp( result ) ) { - result = cursor; - } - - a = pointer2cell( a ).payload.integer.more; - b = pointer2cell( b ).payload.integer.more; - } - } - - debug_print( L"multiply_integers returning:\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; + return operate_on_integers( a, b, '*'); } /** @@ -283,9 +248,9 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c\n:", + L"integer_to_string: digit is %ld, hexadecimal is %C\n:", accumulator % base, - hex_digits[accumulator % base] ); + btowc(hex_digits[accumulator % base] )); result = integer_to_string_add_digit( accumulator % base, digits++, diff --git a/src/init.c b/src/init.c index f446dc4..1edb586 100644 --- a/src/init.c +++ b/src/init.c @@ -138,6 +138,7 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); + bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); diff --git a/src/memory/dump.c b/src/memory/dump.c index bd6587f..a5faa87 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -151,3 +151,4 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; } } + diff --git a/src/memory/dump.h b/src/memory/dump.h index e49f453..2293189 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -25,5 +25,4 @@ */ void dump_object( FILE * output, struct cons_pointer pointer ); - #endif diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 9ab797a..aba7a92 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -744,7 +744,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, frame->arg[0] : get_default_stream( true, env ); if ( readp( in_stream ) ) { - debug_print( L"lisp_print: setting input stream\n", DEBUG_IO ); + debug_print( L"lisp_read: setting input stream\n", DEBUG_IO ); debug_dump_object( in_stream, DEBUG_IO ); input = pointer2cell( in_stream ).payload.stream.stream; inc_ref( in_stream ); @@ -1124,3 +1124,31 @@ struct cons_pointer lisp_source( struct stack_frame *frame, return result; } + + +/** + * Print the internal representation of the object indicated by `frame->arg[0]` to the + * (optional, defaults to `stdout`) stream indicated by `frame->arg[1]`. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering print\n", DEBUG_IO ); + struct cons_pointer result = frame->arg[0]; + FILE *output = stdout; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); + + if ( writep( out_stream ) ) { + debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } + dump_object( output, frame->arg[0] ); + + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } + + return result; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 7868c4b..7d7d395 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -201,3 +201,6 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env );